Is there a `ProgressButton`?

Question

I could like to have a button that does double duty as a progress bar.

+ = ........

E.g. a button that fills up with a green background as the task progresses.
I know I can create my own, but if there's something ready made I'd love to use that.

Does anyone know of a free or commercial component that fits the bill?

I would prefer it to work in Delphi-2007, but if it's only available in XE2 that would be OK as well.

Update
TMS has a glassbutton that allows transparency. If you put a Shape (with rounded corners) in a dark green color underneigh, it looks just like the effect that I want.
Just grow the width of the shape to match the progress and you're in business.

When I have time I'll make a button that fills up with a color and put up a link.

Answer 1

I've created one for you. It's nothing cool, because I don't have much experience with component writing, so please take it as it is :)

There are two components available:

• TProgressButton - with basic support of progress bar
• TProgressGlyphButton - the same as above with glyph support

The following properties are valid for both components:

• ProgressMin - low limit of the progress bar
• ProgressMax - high limit of the progress bar
• ProgressValue - current progress bar value
• ProgressAlpha - progress bar opacity (range 0-175, where 175 is maximal visibility)
• ProgressColor - color of the progress bar
• ProgressColored - flag which enables the ProgressColor
• ProgressMargins - margins between button's inner border and the outer of the progress

These properties are valid only for TProgressGlyphButton:

• Images - image list containing the button state images (disabled, default, normal, hot, pressed)
  - if there is not enough images for all states, then only the first one is drawn for all states
• ImageTop - vertical indent of the glyph, valid only when the ImageAlign is set to iaCustom
• ImageLeft - vertical indent of the glyph, valid only when the ImageAlign is set to iaCustom
• ImageAlign - glyph alignment style
  - iaLeft aligns glyph to the left and indent it by the result of vertical glyph centering
  - iaRight aligns glyph to the right and indent it by the result of vertical glyph centering
  - iaCustom allows you to specify the glyph coordinates manually (see properties above)

The Font property affects text rendering, so you may change the font style, color or whatever. Please note, that this component need to be used only with enabled Windows Themes.

Both components have demo and source code included; I cannot post the updated code here because of limitations of post length. So I left here the original one.

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   Progress Button - 0.0.0.1   ////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

unit ProgressButton;

interface

uses Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
  SysUtils, ExtCtrls, CommCtrl, UxTheme, Themes;

type
  TButtonState = (bsDisabled, bsDefault, bsNormal, bsButtonHot, bsPressed);
  TBufferType = (btProgress, btButton, btCaption);
  TBufferTypes = set of TBufferType;

  TProgressButton = class(TButton)
  private
    FDrawBuffer: TBitmap;
    FButtonBuffer: TBitmap;
    FProgressBuffer: TBitmap;
    FProgressMin: Integer;
    FProgressMax: Integer;
    FProgressValue: Integer;
    FProgressAlpha: Integer;
    FProgressColor: TColor;
    FProgressColored: Boolean;
    FProgressMargins: Integer;
    FProgressSpacing: Integer;

    FButtonState: TButtonState;
    FFocusInControl: Boolean;
    FMouseInControl: Boolean;

    procedure PrepareButtonBuffer;
    procedure PrepareProgressBuffer;
    procedure PrepareDrawBuffers(const BufferTypes: TBufferTypes);

    procedure SetProgressMin(Value: Integer);
    procedure SetProgressMax(Value: Integer);
    procedure SetProgressValue(Value: Integer);
    procedure SetProgressAlpha(Value: Integer);
    procedure SetProgressColor(Value: TColor);
    procedure SetProgressColored(Value: Boolean);
    procedure SetProgressMargins(Value: Integer);

    function GetButtonState(const ItemState: UINT): TButtonState;

    procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;
    procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
    procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged(var Msg: TMessage); message CM_TEXTCHANGED;
    procedure WMLButtonDblClk(var Msg: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure WMWindowPosChanged(var Msg: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;

  protected
    procedure Loaded; override;
    procedure SetButtonStyle(Value: Boolean); override;
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property ProgressMin: Integer read FProgressMin write SetProgressMin default 0;
    property ProgressMax: Integer read FProgressMax write SetProgressMax default 100;
    property ProgressValue: Integer read FProgressValue write SetProgressValue default 0;
    property ProgressAlpha: Integer read FProgressAlpha write SetProgressAlpha default 75;
    property ProgressColor: TColor read FProgressColor write SetProgressColor default $00804000;
    property ProgressColored: Boolean read FProgressColored write SetProgressColored default False;
    property ProgressMargins: Integer read FProgressMargins write SetProgressMargins default 1;
  end;

procedure Register;

implementation


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.Create - component constructor   ///////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// AOwner - component owner

constructor TProgressButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  if csDesigning in ComponentState then
    if not ThemeServices.ThemesEnabled then
      begin
        raise EInvalidOperation.Create(
          'Hi, I''m the ProgressButton control, but I cannot be loaded because' + sLineBreak +
          'you don''t have the Windows Themes enabled and my initial developer' + sLineBreak +
          'was so lazy to paint me without them.');
      end;

  Width := 185;
  Height := 25;

  FProgressMin := 0;
  FProgressMax := 100;
  FProgressValue := 0;
  FProgressAlpha := 75;
  FProgressColor := $00804000;
  FProgressColored := False;
  FProgressMargins := 1;
  FButtonState := bsNormal;

  if Win32MajorVersion >= 6 then
    FProgressSpacing := 1
  else
    FProgressSpacing := 2;

  FDrawBuffer := TBitmap.Create;
  FDrawBuffer.PixelFormat := pf32Bit;
  FButtonBuffer := TBitmap.Create;
  FButtonBuffer.PixelFormat := pf32Bit;
  FProgressBuffer := TBitmap.Create;
  FProgressBuffer.PixelFormat := pf32Bit;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.Destroy - component destructor   ///////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

destructor TProgressButton.Destroy;
begin
  inherited Destroy;
  FDrawBuffer.Free;
  FButtonBuffer.Free;
  FProgressBuffer.Free;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.PrepareButtonBuffer - prepare the button bitmap to be drawn   //////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

procedure TProgressButton.PrepareButtonBuffer;
var
  ThemedButton: TThemedButton;
  ThemedDetails: TThemedElementDetails;
begin
  ThemedButton := tbButtonDontCare;

  case FButtonState of
    bsDisabled: ThemedButton := tbPushButtonDisabled;
    bsDefault: ThemedButton := tbPushButtonDefaulted;
    bsNormal: ThemedButton := tbPushButtonNormal;
    bsButtonHot: ThemedButton := tbPushButtonHot;
    bsPressed: ThemedButton := tbPushButtonPressed;
  end;

  PerformEraseBackground(Self, FButtonBuffer.Canvas.Handle);

  ThemedDetails := ThemeServices.GetElementDetails(ThemedButton);
  ThemeServices.DrawElement(FButtonBuffer.Canvas.Handle, ThemedDetails, ClientRect, nil);
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.PrepareProgressBuffer - prepare the progress bitmap to be drawn   //////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

procedure TProgressButton.PrepareProgressBuffer;
var
  ProgressBar: TRect;
  ProgressChunk: TRect;
  ThemedDetails: TThemedElementDetails;

  procedure ColorizeBitmap(const Bitmap: TBitmap; const Color: TColor);
  type
    PPixelRec = ^TPixelRec;
    TPixelRec = packed record
      B: Byte;
      G: Byte;
      R: Byte;
      Alpha: Byte;
    end;
  var
    X: Integer;
    Y: Integer;
    R: Integer;
    G: Integer;
    B: Integer;
    Gray: Byte;
    Pixel: PPixelRec;
  begin
    R := GetRValue(Color);
    G := GetGValue(Color);
    B := GetBValue(Color);

    for Y := ProgressChunk.Top to ProgressChunk.Bottom - 1 do
    begin
      Pixel := Bitmap.ScanLine[Y];
      Inc(Pixel, FProgressMargins + FProgressSpacing);
      for X := ProgressChunk.Left to ProgressChunk.Right - 1 do
      begin
        Gray := Round((0.299 * Pixel.R) + (0.587 * Pixel.G) + (0.114 * Pixel.B));

        if (Win32MajorVersion >= 6) or ((Win32MajorVersion < 6) and (Gray < 240)) then
        begin
          Pixel.R := MulDiv(R, Gray, 255);
          Pixel.G := MulDiv(G, Gray, 255);
          Pixel.B := MulDiv(B, Gray, 255);
        end;

        Inc(Pixel);
      end;
    end;
  end;

begin
  ProgressBar := Rect(
    ClientRect.Left + FProgressMargins,
    ClientRect.Top + FProgressMargins,
    ClientRect.Right - FProgressMargins,
    ClientRect.Bottom - FProgressMargins);

  ProgressChunk := Rect(
    ProgressBar.Left + FProgressSpacing,
    ProgressBar.Top + FProgressSpacing,
    ProgressBar.Left + FProgressSpacing + Trunc((FProgressValue - FProgressMin) / (FProgressMax - FProgressMin) * (ProgressBar.Right - ProgressBar.Left - (2 * FProgressSpacing))),
    ProgressBar.Bottom - FProgressSpacing);

  PerformEraseBackground(Self, FProgressBuffer.Canvas.Handle);

  ThemedDetails := ThemeServices.GetElementDetails(tpBar);
  ThemeServices.DrawElement(FProgressBuffer.Canvas.Handle, ThemedDetails, ProgressBar, nil);
  ThemedDetails := ThemeServices.GetElementDetails(tpChunk);
  ThemeServices.DrawElement(FProgressBuffer.Canvas.Handle, ThemedDetails, ProgressChunk, nil);

  if FProgressColored then
    ColorizeBitmap(FProgressBuffer, FProgressColor);
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.PrepareDrawBuffers - prepare the bitmaps to be drawn and render caption   //////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// BufferTypes - set of buffer (element) types 

procedure TProgressButton.PrepareDrawBuffers(const BufferTypes: TBufferTypes);
var
  TextBounds: TRect;
  BlendFunction: TBlendFunction;
begin
  if (csLoading in ComponentState) or (not Assigned(Parent)) then
    Exit;

  FDrawBuffer.Width := Width;
  FDrawBuffer.Height := Height;
  FButtonBuffer.Width := Width;
  FButtonBuffer.Height := Height;
  FProgressBuffer.Width := Width;
  FProgressBuffer.Height := Height;

  if btProgress in BufferTypes then
    PrepareProgressBuffer;
  if btButton in BufferTypes then
    PrepareButtonBuffer;

  BitBlt(FDrawBuffer.Canvas.Handle, 0, 0, Width, Height, FProgressBuffer.Canvas.Handle, 0, 0, SRCCOPY);

  BlendFunction.BlendOp := AC_SRC_OVER;
  BlendFunction.BlendFlags := 0;
  BlendFunction.SourceConstantAlpha := 255 - FProgressAlpha;
  BlendFunction.AlphaFormat := 0;

  AlphaBlend(FDrawBuffer.Canvas.Handle, 0, 0, Width, Height, FButtonBuffer.Canvas.Handle, 0, 0, Width, Height,
    BlendFunction);

  if Caption <> '' then
  begin
    TextBounds := ClientRect;

    if Enabled then
      FDrawBuffer.Canvas.Font.Color := Font.Color
    else
      FDrawBuffer.Canvas.Font.Color := clGrayText;

    SelectObject(FDrawBuffer.Canvas.Handle, Font.Handle);

    SetBkMode(FDrawBuffer.Canvas.Handle, TRANSPARENT);
    //Edit by johan
    //Uncomment if you like your buttons to be pressed.
    (*if (FButtonState = bsPressed) then OffsetRect(TextBounds,1,1); (**)
    //End of edit
    DrawText(FDrawBuffer.Canvas.Handle, PChar(Caption), Length(Caption), TextBounds, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
  end;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.SetProgressMin - setter for ProgressMin property   /////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Value - value to be set

procedure TProgressButton.SetProgressMin(Value: Integer);
begin
  if FProgressMin <> Value then
  begin
    if Value > FProgressMax then
      Exit;

    FProgressMin := Value;
    if FProgressValue < Value then
      FProgressValue := Value;

    PrepareDrawBuffers([btProgress]);
    Invalidate;
  end;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.SetProgressMax - setter for ProgressMax property   /////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Value - value to be set

procedure TProgressButton.SetProgressMax(Value: Integer);
begin
  if FProgressMax <> Value then
  begin
    if Value < FProgressMin then
      Exit;

    FProgressMax := Value;
    if FProgressValue > Value then
      FProgressValue := Value;

    PrepareDrawBuffers([btProgress]);
    Invalidate;
  end;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.SetProgressValue - setter for ProgressValue property   /////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Value - value to be set

procedure TProgressButton.SetProgressValue(Value: Integer);
begin
  if Value < FProgressMin then
    Value := FProgressMin
  else
  if Value > FProgressMax then
    Value := FProgressMax;

  if FProgressValue <> Value then
  begin
    FProgressValue := Value;
    PrepareDrawBuffers([btProgress]);
    Invalidate;
  end;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.SetProgressAlpha - setter for ProgressAlpha property   /////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Value - value to be set

procedure TProgressButton.SetProgressAlpha(Value: Integer);
begin
  if Value < 0 then
    Value := 0
  else
  if Value > 175 then
    Value := 175;

  if FProgressAlpha <> Value then
  begin
    FProgressAlpha := Value;
    PrepareDrawBuffers([btProgress]);
    Invalidate;
  end;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.SetProgressColor - setter for ProgressColor property   /////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Value - value to be set

procedure TProgressButton.SetProgressColor(Value: TColor);
begin
  if Value <> FProgressColor then
  begin
    FProgressColor := Value;
    PrepareDrawBuffers([btProgress]);
    Invalidate;
  end;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.SetProgressColored - setter for ProgressColored property   /////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Value - value to be set

procedure TProgressButton.SetProgressColored(Value: Boolean);
begin
  if Value <> FProgressColored then
  begin
    FProgressColored := Value;
    PrepareDrawBuffers([btProgress]);
    Invalidate;
  end;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.SetProgressMargins - setter for ProgressMargins property   /////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Value - value to be set

procedure TProgressButton.SetProgressMargins(Value: Integer);
begin
  if Value <> FProgressMargins then
  begin
    if (Width - (2 * Value) <= 0) or (Height - (2 * Value) <= 0) or (Value < 0) then
      Exit;

    FProgressMargins := Value;
    PrepareDrawBuffers([btProgress]);
    Invalidate;
  end;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.GetButtonState - helper function for translating item state to internal button state   /////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Result - current button state
// ItemState - item state passed from the CNDrawItem method

function TProgressButton.GetButtonState(const ItemState: UINT): TButtonState;
begin
  if not Enabled then
    Result := bsDisabled
  else
  begin
    if (ItemState and ODS_SELECTED <> 0) then
      Result := bsPressed
    else
    if FMouseInControl then
      Result := bsButtonHot
    else
    if FFocusInControl or (ItemState and ODS_FOCUS <> 0) then
      Result := bsDefault
    else
      Result := bsNormal;
  end;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.CNDrawItem - control message fired when the custom control changes its state   /////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Msg - message structure

procedure TProgressButton.CNDrawItem(var Msg: TWMDrawItem);
var
  ButtonState: TButtonState;
begin
  if not Assigned(Parent) then
    Exit;

  ButtonState := GetButtonState(Msg.DrawItemStruct^.itemState);

  if FButtonState <> ButtonState then
  begin
    FButtonState := ButtonState;
    PrepareDrawBuffers([btButton]);
  end;

  BitBlt(Msg.DrawItemStruct^.hDC, 0, 0, Width, Height, FDrawBuffer.Canvas.Handle, 0, 0, SRCCOPY);
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.CMMouseEnter - control message fired when the mouse cursor enters the control   ////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Msg - message structure

procedure TProgressButton.CMMouseEnter(var Msg: TMessage);
begin
  inherited;
  if not (csDesigning in ComponentState) then
  begin
    FMouseInControl := True;
    Repaint;
  end;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.CMMouseLeave - control message fired when the mouse cursor leaves the control   ////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Msg - message structure

procedure TProgressButton.CMMouseLeave(var Msg: TMessage);
begin
  inherited;
  if not (csDesigning in ComponentState) then
  begin
    FMouseInControl := False;
    Repaint;
  end;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.CMFontChanged - control message fired when the font is changed   ///////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Msg - message structure

procedure TProgressButton.CMFontChanged(var Msg: TMessage);
begin
  inherited;
  PrepareDrawBuffers([btCaption]);
  Invalidate;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.CMTextChanged - control message fired when the caption is changed   ////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Msg - message structure

procedure TProgressButton.CMTextChanged(var Msg: TMessage);
begin
  inherited;
  PrepareDrawBuffers([btCaption]);
  Invalidate;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.WMLButtonDblClk - window message fired when the left mouse button is double-clicked   //////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Msg - message structure

procedure TProgressButton.WMLButtonDblClk(var Msg: TWMLButtonDblClk);
begin
  Perform(WM_LBUTTONDOWN, Msg.Keys, Longint(Msg.Pos));
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.WMWindowPosChanged - window message fired when the window size / position is changed   /////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Msg - message structure

procedure TProgressButton.WMWindowPosChanged(var Msg: TWMWindowPosChanged);
begin
  inherited;
  PrepareDrawBuffers([btButton, btProgress]);
  Invalidate;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.Loaded - method fired when the component loading finishes   ////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

procedure TProgressButton.Loaded;
begin
  inherited;
  PrepareDrawBuffers([btButton, btProgress]);
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.SetButtonStyle - function called from parent's CMFocusChanged   ////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Value - value to be set

procedure TProgressButton.SetButtonStyle(Value: Boolean);
begin
  if Value <> FFocusInControl then
  begin
    FFocusInControl := Value;
    Invalidate;
  end;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   TProgressButton.CreateParams - override the create parameters   ////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

// Params - create parameters

procedure TProgressButton.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or BS_OWNERDRAW;
end;


////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
/////   Register - registration procedure   ////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

procedure Register;
begin
  RegisterComponents('StackOverflow', [TProgressButton]);
end;

end.

Here's the latest version. I don't have a time to describe it and to finish demo now. It's finally inherited from TCustomButton, supports action images (there's a new property ImageSource which assigns what will be used as an image source, isNone = no image; isAction = image is taken from the action's image list; isCustom = uses the Images list).

To be continue :)

And here how it may looks like:

Answer 2

Googling for 'delphi progress bar with image' quickly gave me this hit:

AlProgressBar on http://www.torry.net/pages.php?id=504

If it has an onclick handler that shopuld do the trick

I leave it you do Google further