Delphi: draw own progress bar in List View

Question

I have a list view and draw it with OwnerDraw.

How to draw a simple and smooth progress bar with rounded angles and a line on the top a

Answer 1

pixel by pixel ;-)

Commercially, these come close:

• http://www.tmssoftware.com/site/advprogr.asp
• http://devexpress.com/Products/VCL/#ctl00_ctl00_Content_Content_ctl30|2

Use their drawing logic to embed those in your owner drawn listview.

Answer 2

Font will be incorrect for additional sub-items.

Sender.Canvas.Font.OnChange(Sender);

Thanks to Delphi TListview OwnerDraw SubItems - change default font (it's bold somehow after you Draw on the canvas)

e.g.:

procedure TForm1.ListView1CustomDrawSubItem(Sender: TCustomListView;
  Item: TListItem; SubItem: Integer; State: TCustomDrawState;
  var DefaultDraw: Boolean);
var
  ListView: TListView absolute Sender;
  R: TRect;
begin
  DefaultDraw := SubItem <> StatusColumnIndex;
  if not DefaultDraw then
  begin
    ListView_GetSubItemRect(ListView.Handle, Item.Index, SubItem,
      LVIR_BOUNDS, @R);
    DrawStatus(ListView.Canvas.Handle, R, State, ListView.Font, 'Downloading',
      Random(101) / 100);
  end;
Sender.Canvas.Font.OnChange(Sender);
end;

Answer 3

Could something like this do?

uses
  CommCtrl, Themes;

const
  StatusColumnIndex = 2;

procedure DrawStatus(DC: HDC; R: TRect; State: TCustomDrawState; Font: TFont;
  const Txt: String; Progress: Single);
var
  TxtRect: TRect;
  S: String;
  Details: TThemedElementDetails;
  SaveBrush: HBRUSH;
  SavePen: HPEN;
  TxtFont: TFont;
  SaveFont: HFONT;
  SaveTextColor: COLORREF;
begin
  FillRect(DC, R, 0);
  InflateRect(R, -1, -1);
  TxtRect := R;
  S := Format('%s %.1f%%', [Txt, Progress * 100]);
  if ThemeServices.ThemesEnabled then
  begin
    Details := ThemeServices.GetElementDetails(tpBar);
    ThemeServices.DrawElement(DC, Details, R, nil);
    InflateRect(R, -2, -2);
    R.Right := R.Left + Trunc((R.Right - R.Left) * Progress);
    Details := ThemeServices.GetElementDetails(tpChunk);
    ThemeServices.DrawElement(DC, Details, R, nil);
  end
  else
  begin
    SavePen := SelectObject(DC, CreatePen(PS_NULL, 0, 0));
    SaveBrush := SelectObject(DC, CreateSolidBrush($00EBEBEB));
    Inc(R.Right);
    Inc(R.Bottom);
    RoundRect(DC, R.Left, R.Top, R.Right, R.Bottom, 3, 3);
    R.Right := R.Left + Trunc((R.Right - R.Left) * Progress);
    DeleteObject(SelectObject(DC, CreateSolidBrush($00FFC184)));
    RoundRect(DC, R.Left, R.Top, R.Right, R.Bottom, 3, 3);
    if R.Right > R.Left + 3 then
      Rectangle(DC, R.Right - 3, R.Top, R.Right, R.Bottom);
    DeleteObject(SelectObject(DC, SaveBrush));
    DeleteObject(SelectObject(DC, SavePen));
  end;
  TxtFont := TFont.Create;
  try
    TxtFont.Assign(Font);
    TxtFont.Height := TxtRect.Bottom - TxtRect.Top;
    TxtFont.Color := clGrayText;
    SetBkMode(DC, TRANSPARENT);
    SaveFont := SelectObject(DC, TxtFont.Handle);
    SaveTextColor := SetTextColor(DC, GetSysColor(COLOR_GRAYTEXT));
    DrawText(DC, PChar(S), -1, TxtRect, DT_SINGLELINE or DT_CENTER or
      DT_VCENTER or DT_END_ELLIPSIS or DT_NOPREFIX);
    SetBkMode(DC, TRANSPARENT);
  finally
    DeleteObject(SelectObject(DC, SaveFont));
    SetTextColor(DC, SaveTextColor);
    TxtFont.Free;
  end;
end;

procedure TForm1.ListView1CustomDrawSubItem(Sender: TCustomListView;
  Item: TListItem; SubItem: Integer; State: TCustomDrawState;
  var DefaultDraw: Boolean);
var
  ListView: TListView absolute Sender;
  R: TRect;
begin
  DefaultDraw := SubItem <> StatusColumnIndex;
  if not DefaultDraw then
  begin
    ListView_GetSubItemRect(ListView.Handle, Item.Index, SubItem,
      LVIR_BOUNDS, @R);
    DrawStatus(ListView.Canvas.Handle, R, State, ListView.Font, 'Downloading',
      Random(101) / 100);
  end;
end;

With thanks to David Heffernan's tip and to Sertac Akyuz's answer.