delphi - drawing a checkbox in a TListView

Question

I need to draw a checkbox in a particular column in aTListView, so i check this question How can I setup TListView with CheckBoxes in only certain columns? and in the accepted answer suggest use the method described in this another question How to set a Checkbox TStringGrid in Delphi?, now porting that code to work with a ListView i come with this :

procedure TForm15.ListView1CustomDrawSubItem(Sender: TCustomListView; Item: TListItem; SubItem: Integer; State: TCustomDrawState; var DefaultDraw: Boolean);
const
  PADDING = 4;
var
  h    : HTHEME;
  s    : TSize;
  r    : TRect;
  Rect : TRect;
  i    : Integer;
  Dx   : Integer;
begin
  if (SubItem=1) then
  begin
    DefaultDraw:=True;
    Rect  :=Item.DisplayRect(drBounds);
    Dx:=0;

    for i := 0 to SubItem do
    Inc(Dx,Sender.Column[i].Width);
    Rect.Left  :=Rect.Left+Dx;

    Rect.Right :=Rect.Left+Sender.Column[SubItem+1].Width;

    FillRect(Sender.Canvas.Handle, Rect, GetStockObject(WHITE_BRUSH));
    s.cx := GetSystemMetrics(SM_CXMENUCHECK);
    s.cy := GetSystemMetrics(SM_CYMENUCHECK);
    if UseThemes then
    begin
      h := OpenThemeData(Sender.Handle, 'BUTTON');
      if h <> 0 then
        try
          GetThemePartSize(h, Sender.Canvas.Handle, BP_CHECKBOX, CBS_CHECKEDNORMAL, nil, TS_DRAW, s);
          r.Top    := Rect.Top + (Rect.Bottom - Rect.Top - s.cy) div 2;
          r.Bottom := r.Top + s.cy;
          r.Left   := Rect.Left + PADDING;
          r.Right  := r.Left + s.cx;
          DrawThemeBackground(h, Sender.Canvas.Handle, BP_CHECKBOX, IfThen(CompareText(Item.SubItems[1],'True')=0, CBS_CHECKEDNORMAL, CBS_UNCHECKEDNORMAL), r, nil);
        finally
          CloseThemeData(h);
        end;
    end
    else
    begin
      r.Top    := Rect.Top + (Rect.Bottom - Rect.Top - s.cy) div 2;
      r.Bottom := r.Top + s.cy;
      r.Left   := Rect.Left + PADDING;
      r.Right  := r.Left + s.cx;
      DrawFrameControl(Sender.Canvas.Handle, r, DFC_BUTTON, IfThen(CompareText(Item.SubItems[1],'True')=0, DFCS_CHECKED, DFCS_BUTTONCHECK));
    end;
   //r := Classes.Rect(r.Right + PADDING, Rect.Top, Rect.Right, Rect.Bottom);
   // DrawText(Sender.Canvas.Handle,   StringGrid1.Cells[ACol, ARow], length(StringGrid1.Cells[ACol, ARow]),  r, DT_SINGLELINE or DT_VCENTER or DT_LEFT or DT_END_ELLIPSIS);
  end
  else
  DefaultDraw:=False;
end;

but i fail miserably in my attempt to draw a checkbox :(, can someone point me in the right direction to draw the checkbox in the listview, (the code does not draw any checkbox in the listview).

The listview is in vsReport mode and had 3 columns, i want put the checkbox in the third column. please don't suggest which use a thrid party component, i want use the TlistView control.

UPDATE 1 : thanks to the sertac recomendattion setting the DefaultDraw value now the checkboxes are shown, but the another columns looks awfull.

UPDATE 2 , following the Andreas suggestions the listview now look better, but still shown the black box;

procedure TForm15.ListView1CustomDrawSubItem(Sender: TCustomListView; Item: TListItem; SubItem: Integer; State: TCustomDrawState; var DefaultDraw: Boolean);
var
  h    : HTHEME;
  s    : TSize;
  r    : TRect;
  Rect : TRect;
  i    : Integer;
  Dx   : Integer;
begin
  if (SubItem=2) then
  begin
    DefaultDraw:=False;
    Rect  :=Item.DisplayRect(drBounds);

    Dx:=0;
    for i := 0 to SubItem-1 do
      Inc(Dx,Sender.Column[i].Width);

    Rect.Left  :=Rect.Left+Dx;
    Rect.Right :=Rect.Left+Sender.Column[SubItem].Width;
    FillRect(Sender.Canvas.Handle, Rect, GetStockObject(WHITE_BRUSH));
    s.cx := GetSystemMetrics(SM_CXMENUCHECK);
    s.cy := GetSystemMetrics(SM_CYMENUCHECK);
    Dx   := (Sender.Column[SubItem].Width-GetSystemMetrics(SM_CXMENUCHECK)) div 2;
    if UseThemes then
    begin
      h := OpenThemeData(Sender.Handle, 'BUTTON');
      if h <> 0 then
        try
          GetThemePartSize(h, Sender.Canvas.Handle, BP_CHECKBOX, CBS_CHECKEDNORMAL, nil, TS_DRAW, s);
          r.Top    := Rect.Top + (Rect.Bottom - Rect.Top - s.cy) div 2;
          r.Bottom := r.Top + s.cy;
          r.Left   := Rect.Left + Dx;
          r.Right  := r.Left + s.cx;
          DrawThemeBackground(h, Sender.Canvas.Handle, BP_CHECKBOX, IfThen(CompareText(Item.SubItems[SubItem-1],'True')=0, CBS_CHECKEDNORMAL, CBS_UNCHECKEDNORMAL), r, nil);
        finally
          CloseThemeData(h);
        end;
    end
    else
    begin
      r.Top    := Rect.Top + (Rect.Bottom - Rect.Top - s.cy) div 2;
      r.Bottom := r.Top + s.cy;
      r.Left   := Rect.Left + Dx;
      r.Right  := r.Left + s.cx;
      DrawFrameControl(Sender.Canvas.Handle, r, DFC_BUTTON, IfThen(CompareText(Item.SubItems[SubItem-1],'True')=0, DFCS_CHECKED, DFCS_BUTTONCHECK));
    end;
  end;
end;

Answer 1

One relatively simple way to get rid of this bug is to owner-draw the entire item. Set OwnerDraw := true, remove your OnCustomDrawSubItem routine, and add

procedure TForm15.ListView1DrawItem(Sender: TCustomListView; Item: TListItem;
  Rect: TRect; State: TOwnerDrawState);

  function ShrinkRect(const r: TRect; const X0, X1, Y0, Y1: integer): TRect; inline;
  begin
    result := r;
    inc(result.Left, X0);
    inc(result.Top, Y0);
    dec(result.Right, X1);
    dec(result.Bottom, Y1);
  end;

const
  CHECK_COL = 2;
  PADDING = 4;
var
  r: TRect;
  i: Integer;
  s: string;
  size: TSize;
  h: HTHEME;
begin

  FillRect(Sender.Canvas.Handle, Rect, GetStockObject(WHITE_BRUSH));
  r := Rect;
  inc(r.Left, PADDING);
  for i := 0 to TListView(Sender).Columns.Count - 1 do
  begin
    r.Right := r.Left + Sender.Column[i].Width;
    if i <> CHECK_COL then
    begin
      if i = 0 then
      begin
        s := Item.Caption;
        if not IsWindowVisible(ListView_GetEditControl(Sender.Handle)) then
        begin
          if UseThemes and ([odSelected, odHotLight] * State <> []) then
          begin
            h := OpenThemeData(Sender.Handle, 'LISTVIEW');
            if h <> 0 then
              try
                DrawThemeBackground(h, Sender.Canvas.Handle, LVP_GROUPHEADER, IfThen(odSelected in State, LVGH_CLOSESELECTED, LVGH_OPENHOT), ShrinkRect(r, -2, 6, 1, 1), nil);
              finally
                CloseThemeData(h);
              end;
          end;
          if (odSelected in State) and not UseThemes then
            DrawFocusRect(Sender.Canvas.Handle, ShrinkRect(r, -2, 6, 1, 1));
        end;
      end
      else
        s := Item.SubItems[i - 1];
      Sender.Canvas.Brush.Style := bsClear;
      DrawText(Sender.Canvas.Handle,
        PChar(s),
        length(s),
        r,
        DT_SINGLELINE or DT_VCENTER or DT_LEFT or DT_END_ELLIPSIS);
    end
    else
    begin

      size.cx := GetSystemMetrics(SM_CXMENUCHECK);
      size.cy := GetSystemMetrics(SM_CYMENUCHECK);
      if UseThemes then
      begin
        h := OpenThemeData(Sender.Handle, 'BUTTON');
        if h <> 0 then
          try
            GetThemePartSize(h, Sender.Canvas.Handle, BP_CHECKBOX, CBS_CHECKEDNORMAL, nil, TS_DRAW, size);
            r.Top    := Rect.Top + (Rect.Bottom - Rect.Top - size.cy) div 2;
            r.Bottom := r.Top + size.cy;
            r.Left   := r.Left + PADDING;
            r.Right  := r.Left + size.cx;
            DrawThemeBackground(h, Sender.Canvas.Handle, BP_CHECKBOX, IfThen(CompareText(Item.SubItems[1],'True')=0, CBS_CHECKEDNORMAL, CBS_UNCHECKEDNORMAL), r, nil);
          finally
            CloseThemeData(h);
          end;
      end
      else
      begin
        r.Top    := Rect.Top + (Rect.Bottom - Rect.Top - size.cy) div 2;
        r.Bottom := r.Top + size.cy;
        r.Left   := r.Left + PADDING;
        r.Right  := r.Left + size.cx;
        DrawFrameControl(Sender.Canvas.Handle, r, DFC_BUTTON, IfThen(CompareText(Item.SubItems[1],'True')=0, DFCS_CHECKED, DFCS_BUTTONCHECK));
      end;

    end;
    inc(r.Left, Sender.Column[i].Width);
  end;

end;

The code above needs further testing, but is probably in the right direction. Now it's very late, and I have to go.