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 as on a picture below?

I need your help to apply a code below to my needs (my skills don't make it possible to edit).

//  TUbuntuProgress
//  Version 1.2

unit UbuntuProgress;

interface

uses
  Windows, SysUtils, Classes, Controls, Graphics, Math, ExtCtrls;

type
  TUbuntuProgressColorSets = (csOriginal, csBlue, csRed);
  TUbuntuProgressMode = (pmNormal, pmMarquee);
  TMarqueeMode = (mmToLeft, mmToRight);
  TMarqueeSpeed = (msSlow, msMedium, msFast);

  TUbuntuProgress = class(TGraphicControl)
  private
    FColorSet: TUbuntuProgressColorSets;
    FProgressDividers: Boolean;
    FBackgroundDividers: Boolean;
    FMarqueeWidth: Longint;
    FMax: Longint;
    FMode: TUbuntuProgressMode;
    FPosition: Longint;
    FShadow: Boolean;
    FSpeed: TMarqueeSpeed;
    FStep: Longint;
    FVisible: Boolean;
    Buffer: TBitmap;
    DrawWidth: Longint;
    MarqueeMode: TMarqueeMode;
    MarqueePosition: Longint;
    Timer: TTimer;
    procedure SetColorSet(newColorSet: TUbuntuProgressColorSets);
    procedure SetProgressDividers(newProgressDividers: Boolean);
    procedure SetBackgroundDividers(newBackgroundDividers: Boolean);
    procedure SetMarqueeWidth(newMarqueeWidth: Longint);
    procedure SetMax(newMax: Longint);
    procedure SetMode(newMode: TUbuntuProgressMode);
    procedure SetPosition(newPosition: Longint);
    procedure SetShadow(newShadow: Boolean);
    procedure SetSpeed(newSpeed: TMarqueeSpeed);
    procedure SetStep(newStep: Longint);
    procedure SetVisible(newVisible: Boolean);
    procedure MarqueeOnTimer(Sender: TObject);
    procedure PaintNormal;
    procedure PaintMarquee;
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure StepIt;
  published
    property ColorSet: TUbuntuProgressColorSets read FColorSet write SetColorSet;
    property ProgressDividers: Boolean read FProgressDividers write SetProgressDividers;
    property BackgroundDividers: Boolean read FBackgroundDividers write SetBackgroundDividers;
    property MarqueeWidth: Longint read FMarqueeWidth write SetMarqueeWidth;
    property Max: Longint read FMax write SetMax;
    property Mode: TUbuntuProgressMode read FMode write SetMode;
    property Position: Longint read FPosition write SetPosition;
    property Shadow: Boolean read FShadow write SetShadow;
    property Speed: TMarqueeSpeed read FSpeed write SetSpeed;
    property Step: Longint read FStep write SetStep;
    property Height;
    property Visible: Boolean read FVisible write SetVisible;
    property Width;
  end;

procedure Register;

implementation
uses
  UbuntuProgressColors;

{$R UbuntuProgress.dcr}

procedure TUbuntuPRogress.SetColorSet(newColorSet: TUbuntuProgressColorSets);
  begin
    FColorSet := newColorSet;
    Invalidate;
  end;

procedure TUbuntuProgress.SetMarqueeWidth(newMarqueeWidth: Integer);
  var
    OldWidth: Longint;
  begin
    if (newMarqueeWidth < (Width-3)) and (newMarqueeWidth > 0) then
      begin
        OldWidth := FMarqueeWidth;
        FMarqueeWidth := newMarqueeWidth;
        if MarqueeMode = mmToRight then
          MarqueePosition := MarqueePosition - (newMarqueeWidth - OldWidth);
      end;
  end;

procedure TUbuntuProgress.SetProgressDividers(newProgressDividers: Boolean);
  begin
    FProgressDividers := newProgressDividers;
    Invalidate;
  end;

procedure TUbuntuProgress.SetBackgroundDividers(newBackgroundDividers: Boolean);
  begin
    FBackgroundDividers := newBackgroundDividers;
    Invalidate;
  end;

procedure TUbuntuProgress.SetMax(newMax: Integer);
  begin
    if newMax > 0 then
      FMax := newMax;
    if FPosition > FMax then
      FPosition := FMax;
    Invalidate;
  end;

procedure TUbuntuProgress.SetMode(newMode: TUbuntuProgressMode);
  begin
    FMode := newMode;
    if FMode = pmNormal then
      Timer.Enabled := False
    else
      Timer.Enabled := True;
    Invalidate;
  end;

procedure TUbuntuProgress.SetPosition(newPosition: Integer);
  begin
    if (newPosition >= 0) and (newPosition <= FMax) then
      FPosition := newPosition;
    Invalidate;
  end;

procedure TUbuntuProgress.SetShadow(newShadow: Boolean);
  begin
    FShadow := newShadow;
    if FShadow then
      Height := 19
    else
      Height := 18;
    Invalidate;
  end;

procedure TUbuntuProgress.SetSpeed(newSpeed: TMarqueeSpeed);
  begin
    FSpeed := newSpeed;
    case FSpeed of
      msSlow: Timer.Interval := 50;
      msMedium: Timer.Interval := 20;
      msFast: Timer.Interval := 10;
    end;
  end;

procedure TUbuntuProgress.SetStep(newStep: Integer);
  begin
    if (newStep > 0) and (newStep <= (FMax)) then
      FStep := newStep;
  end;

procedure TUbuntuProgress.SetVisible(newVisible: Boolean);
  begin
    FVisible := newVisible;
    if FVisible then
      Invalidate
    else
      Parent.Invalidate;
  end;

procedure TUbuntuProgress.MarqueeOnTimer(Sender: TObject);
  begin
    if not (csDesigning in ComponentState) then
      Invalidate;
  end;

procedure TUbuntuProgress.PaintNormal;
  var
    POverlay: Longint;
    PJoist: Longint;
    PDistance: Extended;
    i, k: Longint;
  begin
    POverlay := Floor((DrawWidth-3)/FMax*FPosition);
    PJoist := Floor((Width-3)/16);
    PDistance := (Width-3)/PJoist;
    with Buffer.Canvas do
      begin
        //3D-Effekt Fortschritt
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[0];
        FillRect(Rect(1, 1, POverlay+1, 2));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[1];
        FillRect(Rect(1, 2, POverlay+1, 3));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[2];
        FillRect(Rect(1, 3, POverlay+1, 4));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[3];
        FillRect(Rect(1, 4, POverlay+1, 5));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[4];
        FillRect(Rect(1, 5, POverlay+1, 6));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[5];
        FillRect(Rect(1, 6, POverlay+1, 7));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[6];
        FillRect(Rect(1, 7, POverlay+1, 8));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[7];
        FillRect(Rect(1, 8, POverlay+1, 9));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[8];
        FillRect(Rect(1, 9, POverlay+1, 12));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[9];
        FillRect(Rect(1, 12, POverlay+1, 13));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[10];
        FillRect(Rect(1, 13, POverlay+1, 14));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[11];
        FillRect(Rect(1, 14, POverlay+1, 15));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[12];
        FillRect(Rect(1, 15, POverlay+1, 16));
        Brush.Color := UbuntuProgressColorSets[FColorSet].Progress[13];
        FillRect(Rect(1, 16, POverlay+1, 17));
        //Balken Fortschritt
        if FProgressDividers then
          begin
            for i := 1 to PJoist-1 do
              begin
                if Round(PDistance*i)<=POverlay then
                  for k := 0 to 15 do
                      Pixels[Round(PDistance*i), k+1] := UbuntuProgressColorSets[FColorSet].JoistLeft[k];
                if Round(PDistance*i)+1<=POverlay then
                  for k := 0 to 15 do
                      Pixels[Round(PDistance*i)+1, k+1] := UbuntuProgressColorSets[FColorSet].JoistRight[k];
              end;
          end;
      end;
  end;

procedure TUbuntuProgress.PaintMarquee;
...
  end;

procedure TUbuntuProgress.Paint;
  var
    PJoist: Longint;
    PDistance: Extended;
    i: Longint;
  begin
    inherited;
    if Visible or ((not Visible) and (csDesigning in ComponentState)) then
      begin
        if FShadow then
          DrawWidth := Width
        else
          DrawWidth := Width + 1;
        PJoist := Floor((Width-3)/16);
        PDistance := (Width-3)/PJoist;
        Buffer.Width := Width;
        Buffer.Height := Height; //19
        with Buffer.Canvas do
          begin
            Brush.Style := bsSolid;
            Pen.Style := psSolid;
            //Eckpixel
            Pixels[0, 0] := $00C6C7CE;{-}
            Pixels[DrawWidth-2, 0] := $00C6C7CE;{-}
            Pixels[DrawWidth-2, 17] := $00C6C7CE;{-}
            Pixels[0, 17] := $00C6C7CE;{-}
            //Ьbergang
            Pixels[1, 0] := $00737584;{-}
            Pixels[DrawWidth-3, 0] := $00737584;{-}
            Pixels[DrawWidth-2, 1] := $00737584;{-}
            Pixels[DrawWidth-2, 16] := $00737584;{-}
            Pixels[DrawWidth-3, 17] := $00737584;{-}
            Pixels[1, 17] := $00737584;{-}
            Pixels[0, 16] := $00737584;{-}
            Pixels[0, 1] := $00737584;{-}
            //Seitenlinien
            Pen.Color := $00636973;{-}
            MoveTo(2, 0);
            LineTo(DrawWidth-3, 0);
            MoveTo(DrawWidth-2, 2);
            LineTo(DrawWidth-2, 16);
            MoveTo(DrawWidth-4, 17);
            LineTo(1, 17);
            MoveTo(0, 15);
            LineTo(0, 1);
            //Schatten
            if FShadow then
              begin
                Pixels[0, 18] := $00E7EBEF;{-}
                Pixels[1, 18] := $00DEE3E7;{-}
                Pixels[DrawWidth-3, 18] := $00DEE3E7;{-}
                Pixels[DrawWidth-2, 18] := $00E7EBEF;{-}
                Pixels[DrawWidth-1, 18] := $00E7EBEF;{-}
                Pixels[DrawWidth-1, 17] := $00E7EBEF;{-}
                Pixels[DrawWidth-1, 16] := $00DEE3E7;{-}
                Pixels[DrawWidth-1, 1] := $00DEE3E7;{-}
                Pixels[DrawWidth-1, 0] := $00E7EBEF;{-}
                Pen.Color := $00D6D7DE;{-}
                MoveTo(2, 18);
                LineTo(DrawWidth-3, 18);
                MoveTo(DrawWidth-1, 15);
                LineTo(DrawWidth-1, 1);
              end;
            //3D-Effekt Innen
            Brush.Color := $00F7F7F7;{-}
            FillRect(Rect(1, 1, DrawWidth-2, 3));
            Brush.Color := $00F7F3F7;{-}
            FillRect(Rect(1, 3, DrawWidth-2, 5));
            Brush.Color := $00EFF3F7;{-}
            FillRect(Rect(1, 5, DrawWidth-2, 8));
            Brush.Color := $00E7E7EF;{-}
            FillRect(Rect(1, 8, DrawWidth-2, 9));
            Brush.Color := $00E7EBEF;{-}
            FillRect(Rect(1, 9, DrawWidth-2, 12));
            Brush.Color := $00EFEFE7;{-}
            FillRect(Rect(1, 12, DrawWidth-2, 13));
            Brush.Color := $00EFF3F7;{-}
            FillRect(Rect(1, 13, DrawWidth-2, 14));
            Brush.Color := $00EFEFF7;{-}
            FillRect(Rect(1, 14, DrawWidth-2, 16));
            Brush.Color := $00F7F7FF;{-}
            FillRect(Rect(1, 16, DrawWidth-2, 17));
            //Balken Innen
            for i := 1 to PJoist-1 do
              if FBackgroundDividers then
                begin
                  Pen.Color := $00DEDBDE;{-}
                  MoveTo(Round(PDistance*i), 1);
                  LineTo(Round(PDistance*i), 17);
                  Pen.Color := $00D8D5E0;{-}
                  MoveTo(Round(PDistance*i), 8);
                  LineTo(Round(PDistance*i), 13);
                  Pen.Color := $00FCF5FC;{-}
                  MoveTo(Round(PDistance*i)+1, 1);
                  LineTo(Round(PDistance*i)+1, 17);
                  Pen.Color := $00EDEDF5;{-}
                  MoveTo(Round(PDistance*i)+1, 8);
                  LineTo(Round(PDistance*i)+1, 13);
                end;
          end;
        case FMode of
          pmNormal: PaintNormal;
          pmMarquee:
            begin
              if not (csDesigning in ComponentState) then
                PaintMarquee;
              end;
        end;
        BitBlt(Canvas.Handle, 0, 0, Width, 19, Buffer.Canvas.Handle, 0, 0, SRCCOPY);
      end;
  end;

procedure TUbuntuProgress.SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer; AHeight: Integer);
  begin
    if AWidth < 100 then
      AWidth := 100;
    if FShadow then
      inherited SetBounds(ALeft, ATop, AWidth, 19)
    else
      inherited SetBounds(ALeft, ATop, AWidth, 18);
  end;

procedure TUbuntuProgress.StepIt;
  begin
    if FMode = pmNormal then
      begin
        FPosition := FPosition+FStep;
        if FPosition > FMax then
          FPosition := 0;
        Invalidate;
      end;
  end;

constructor TUbuntuProgress.Create(AOwner: TComponent);
  begin
    inherited Create(AOwner);
    ControlStyle := ControlStyle + [csFixedHeight, csOpaque];
    Buffer := TBitmap.Create;
    Timer := TTimer.Create(Self);
    Timer.Enabled := False;
    Timer.Interval := 20;
    Timer.OnTimer := MarqueeOnTimer;
    FColorSet := csOriginal;
    FProgressDividers := True;
    FBackgroundDividers := True;
    FMarqueeWidth := 30;
    FMax := 100;
    FMode := pmNormal;
    FPosition := 50;
    FShadow := True;
    FSpeed := msMedium;
    FStep := 1;
    MarqueeMode := mmToRight;
    MarqueePosition := 0;
    Height := 19;
    Width := 150;
    Visible := True;
  end;

destructor TUbuntuProgress.Destroy;
  begin
    Timer.Free;
    Buffer.Free;
    inherited;
  end;

procedure Register;
begin
  RegisterComponents('Ubuntu', [TUbuntuProgress]);
end;

end.

Thanks!

Adagio

Before calling invalidate in get/set methods, you should always check csCreating/csDestroying clags, and also if a handle is allocated, otherwise it can crash. – Reason

Answer 1

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.

Tater

Wow! Thanks!!! You are too good :) I need to draw not themed progress bars. Could you tell me how to change a DrawStatus procedure? It doesn't draw a rounded rectangle. How to '"fillrect"? – Adagio

could you change the code to draw correctly without themes please (it doesn't now)? I will accept an answer? Thanks. – Adagio

This routine behaves just fine if themes aren't enabled. Otherwise, you can delete the theming part yourself. – Tater

i just wanted to add from the Windows UX Guidelines: Don't put the percentage complete or any other text on a progress bar. Such text isn't accessible and isn't compatible with using themes. and Don't give the percentage completed or remaining because that information is conveyed by the progress bar itself. (msdn.microsoft.com/en-us/library/aa511486.aspx) – Thyself

@Ian I know! But it's what OP asked. – Tater

You might want to integrate Sertac's neat workaround to a bug I appear to have found when working with this code: #8193461 – Capitate

And you'll be pleased to hear that I'm now using this code in my product. I'm using it for a progress form for a long running multi-threaded calculation. – Capitate

@David It's always nice to hear my code is actually used. Thanks and good luck. – Tater

There is something wrong with FillRect(DC, R, 0), when status is not the latest column, all fonts of the remaining columns gets bold. – Diphase

Actually the problem is this: ListView.Canvas.Handle; A single call to Canvas.Handle causes the problem – Diphase

Answer 2

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.

Walz

Thanks! Even if I see a source code I won't make anything :) A lack of knowledge. :( Or it's easy? I will try :) – Adagio

As I understood I need to paint pixel by pixel only rounded angles, the beginning/end of a bar? – Adagio

Answer 3

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;

Isogamete