Create a button that accepts .PNG images as Glyph

Question

I'm trying to understand how the SpeedButton Glyph property work, I find that the field declared as:

FGlyph: TObject;

While the property as:

property Glyph: TBitmap read GetGlyph write SetGlyph stored HasCustomGlyph;

That put me in a way where I can't understand that code even if I read it line by line, when I was trying to create my own SpeedButton that accepts .PNG images too instead of .bmp images only.

For the first time I was thinking to declare the property as TPicture instead of TBitmap.

Is there any way to create MySpeedButton with Glyph : TPicture?

What I try is below:

TMyButton = class(TSpeedButton)
    private
     //
    FGlyph: TPicture;
    procedure SetGlyph(const Value: TPicture);
    protected
    //
    public
    //
    published
    //
      Property Glyph : TPicture read FGlyph write SetGlyph;
  end;

And the procedure:

procedure TMyButton.SetGlyph(const Value: TPicture);
begin
  FGlyph := Value;
end;

Answer 1

Your SetGlyph() needs to call FGlyph.Assign(Value) instead of FGlyph := Value. Be sure to create FGlyph in the constructor and destroy it in the destructor. Then you can call draw the graphic in an overriden Paint() when Graphic is not empty.

type
  TMyButton = class(TGraphicControl)
  private
    FGlyph: TPicture;
    procedure GlyphChanged(Sender: TObject);
    procedure SetGlyph(const Value: TPicture);
    protected
      procedure Paint; override;
    public
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
    published
      property Glyph : TPicture read FGlyph write SetGlyph;
  end;

constructor TMyButton.Create(AOwner: TComponent);
begin
  inherited;
  FGlyph := TPicture.Create;
  FGlyph.OnChange := GlyphChanged;
end;

destructor TMyButton.Destroy;
begin
  FGlyph.Free;
  inherited;
end;

procedure TMyButton.GlyphChanged(Sender: TObject);
begin
  Invalidate;
end;

procedure TMyButton.SetGlyph(const Value: TPicture);
begin
  FGlyph.Assign(Value):
end;

procedure TMyButton.Paint;
begin
 ...
  if (FGlyph.Graphic <> nil) and (not FGlyph.Graphic.Empty) then
    Canvas.Draw(..., FGlyph.Graphic);
 ... 
end;

Answer 2

I have created a similar component that is a SpeedButton which accepts a TPicture as its Glyph.

this is the unit. I hope you benefit well from it.

    unit ncrSpeedButtonunit;

interface

uses
  Winapi.Windows, Vcl.Controls, Winapi.Messages, Vcl.Graphics, System.Classes;

type
  TButtonState = (bs_Down, bs_Normal, bs_Active);

  TGlyphCoordinates = class(TPersistent)
  private
    FX: integer;
    FY: integer;
    FOnChange: TNotifyEvent;
    procedure SetX(aX: integer);
    procedure SetY(aY: integer);
    function GetX: integer;
    function GetY: integer;
  public
    procedure Assign(aValue: TPersistent); override;
  published
    property X: integer read GetX write SetX;
    property Y: integer read GetY write SetY;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  TNCRSpeedButton = class(TGraphicControl)
  private
    FGlyph: TPicture;
    FGlyphCoordinates: TGlyphCoordinates;
    FColor: TColor;
    FActiveColor: TColor;
    FDownColor: TColor;
    FBorderColor: TColor;
    Fstate: TButtonState;
    FFlat: boolean;
    FTransparent: boolean;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMMouseDown(var Message: TMessage); message WM_LBUTTONDOWN;
    procedure CMMouseUp(var Message: TMessage); message WM_LBUTTONUP;
    procedure SetGlyph(aGlyph: TPicture);
    procedure SetGlyphCoordinates(aCoordinates: TGlyphCoordinates);
    procedure SetColor(aColor: TColor);
    procedure SetActiveColor(aActiveColor: TColor);
    procedure SetDownColor(aDownColor: TColor);
    procedure SetBorderColor(aBorderColor: TColor);
    procedure SetFlat(aValue: boolean);
    procedure GlyphChanged(Sender: TObject);
    procedure CoordinatesChanged(Sender: TObject);
    procedure SetTransparency(aValue: boolean);
  protected
    procedure Paint; override;
    procedure Resize; override;
  public
    Constructor Create(Owner: TComponent); override;
    Destructor Destroy; override;
  published
    property Glyph: Tpicture read FGlyph write SetGlyph;
    property GlyphCoordinates: TGlyphCoordinates read FGlyphCoordinates write SetGlyphCoordinates;
    property Color: TColor read FColor write SetColor;
    property ActiveColor: TColor read FActiveColor write SetActiveColor;
    property DownColor: TColor read FDownColor write SetDownColor;
    property BorderColor: TColor read FBorderColor write SetBorderColor;
    property Flat: boolean read FFlat write SetFlat;
    property IsTransparent: boolean read FTransparent write SetTransparency;
    property ParentShowHint;
    property ParentBiDiMode;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseActivate;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
  end;


implementation

{ TNCRSpeedButton }

Constructor TNCRSpeedButton.Create(Owner: TComponent);
begin
  inherited Create(Owner);
  FGlyph := TPicture.Create;
  FGlyph.OnChange := GlyphChanged;
  FGlyphCoordinates := TGlyphCoordinates.Create;
  FGlyphCoordinates.OnChange := CoordinatesChanged;
  FState := bs_Normal;
  FColor := clBtnFace;
  FActiveColor := clGradientActiveCaption;
  FDownColor := clHighlight;
  FBorderColor := clBlue;
  FFlat := False;
  FTransparent := False;
  SetBounds(0, 0, 200, 50);
end;

Destructor TNCRSpeedButton.Destroy;
begin
  FGlyph.Free;
  FGlyphCoordinates.Free;
  inherited;
end;

procedure CreateMask(aCanvas: TCanvas; Area: TRect; aColor: Tcolor);
  var
  EBitmap, OBitmap: TBitmap;
begin

  EBitmap := TBitmap.Create;
  OBitmap := TBitmap.Create;
  try
    EBitmap.Width := Area.Width ;
    EBitmap.Height := Area.Height;
    EBitmap.Canvas.CopyRect(Area, aCanvas, Area);

    OBitmap.Width := Area.Width;
    OBitmap.Height := Area.Height;
    OBitmap.Canvas.CopyRect(Area, aCanvas, Area);
    OBitmap.Canvas.Brush.Color := aColor;
    OBitmap.Canvas.Pen.Style := psClear;

    OBitmap.Canvas.Rectangle(Area);

    aCanvas.Draw(0, 0, EBitmap);
    aCanvas.Draw(0, 0, OBitmap, 127);
  finally
    EBitmap.free;
    OBitmap.free;
  end;
end;

procedure DrawParentImage(Control: TControl; Dest: TCanvas);
var
  SaveIndex: Integer;
  DC: HDC;
  Position: TPoint;
begin
  with Control do
  begin
    if Parent = nil then
      Exit;
    DC := Dest.Handle;
    SaveIndex := SaveDC(DC);
    GetViewportOrgEx(DC, Position);
    SetViewportOrgEx(DC, Position.x - Left, Position.y - Top, nil);
    IntersectClipRect(DC, 0, 0, Parent.ClientWidth, Parent.ClientHeight);
    Parent.Perform(WM_ERASEBKGND, DC, 0);
    Parent.Perform(WM_PAINT, DC, 0);
    RestoreDC(DC, SaveIndex);
  end;
end;

procedure TNCRSpeedButton.Paint;

var
  BackgroundColor: TColor;
begin

  case FState of
    bs_Down: BackgroundColor := FDownColor;
    bs_Normal: BackgroundColor := FColor;
    bs_Active: BackgroundColor := FActiveColor;
  else
    BackgroundColor := FColor;
  end;

  // Drawing Background
  if not FTransparent then
    begin
      Canvas.Brush.Color := BackgroundColor;
      Canvas.FillRect(ClientRect);
    end
  else
    begin
      case FState of
        bs_Down:
          begin
            DrawParentImage(parent, Canvas);
            CreateMask(Canvas, ClientRect, FDownColor);
          end;
        bs_Normal:
          begin
            DrawParentImage(parent, Canvas);
          end;
        bs_Active:
          begin
            DrawParentImage(parent, Canvas);
            CreateMask(Canvas, ClientRect, FActiveColor);
          end;
      end;
    end;

  // Drawing Borders

  Canvas.Pen.Color := FBorderColor;
  Canvas.MoveTo(0, 0);
  if not FFlat then
    begin
      Canvas.LineTo(Width-1, 0);
      Canvas.LineTo(Width-1, Height-1);
      Canvas.LineTo(0, Height-1);
      Canvas.LineTo(0, 0);
    end;

  // Drawing the Glyph

  if (FGlyph.Graphic <> nil) and (not FGlyph.Graphic.Empty) then
    begin
      Canvas.Draw(FGlyphCoordinates.X, FGlyphCoordinates.Y, FGlyph.Graphic);
    end;

end;

procedure TNCRSpeedButton.GlyphChanged(Sender: TObject);
begin
  if (FGlyph.Graphic <> nil) and (not FGlyph.Graphic.Empty) then
  begin
    FGlyphCoordinates.OnChange := nil; // Prevent multiple invalidates
    FGlyphCoordinates.X := (Width - FGlyph.Graphic.Width) div 2;
    FGlyphCoordinates.Y := (Height - FGlyph.Graphic.Height) div 2;
    FGlyphCoordinates.OnChange := CoordinatesChanged;
  end;
  Invalidate;
end;

procedure TNCRSpeedButton.CoordinatesChanged(Sender: TObject);
begin
  Invalidate;
end;

procedure TNCRSpeedButton.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  FState := bs_Active;
  Invalidate;
end;

procedure TNCRSpeedButton.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  FState := bs_Normal;
  Invalidate;
end;

procedure TNCRSpeedButton.CMMouseDown(var Message: TMessage);
begin
  inherited;
  FState := bs_Down;
  Invalidate;
end;

procedure TNCRSpeedButton.CMMouseUp(var Message: TMessage);
begin
  inherited;
  FState := bs_Active;
  Invalidate;
end;

procedure TNCRSpeedButton.SetGlyph(aGlyph: TPicture);
begin
  FGlyph.Assign(aGlyph);
end;

procedure TNCRSpeedButton.Resize;
begin
  if (FGlyph.Graphic <> nil) and (not FGlyph.Graphic.Empty) then
  begin
    FGlyphCoordinates.OnChange := nil; // Prevent multiple invalidates
    FGlyphCoordinates.X := (Width - FGlyph.Graphic.Width) div 2;
    FGlyphCoordinates.Y := (Height - FGlyph.Graphic.Height) div 2;
    FGlyphCoordinates.OnChange := CoordinatesChanged;
  end;
  inherited;
end;

procedure TNCRSpeedButton.SetGlyphCoordinates(aCoordinates: TGlyphCoordinates);
begin
  FGlyphCoordinates.assign(aCoordinates);
end;

procedure TNCRSpeedButton.SetColor(aColor: TColor);
begin
  FColor := aColor;
  Invalidate;
end;

procedure TNCRSpeedButton.SetActiveColor(aActiveColor: TColor);
begin
  FActiveColor := aActiveColor;
  Invalidate;
end;

procedure TNCRSpeedButton.SetDownColor(aDownColor: TColor);
begin
  FDownColor := aDownColor;
  Invalidate;
end;

procedure TNCRSpeedButton.SetBorderColor(aBorderColor: TColor);
begin
  FBorderColor := aBorderColor;
  Invalidate;
end;

procedure TNCRSpeedButton.SetFlat(aValue: boolean);
begin
  FFlat := aValue;
  Invalidate;
end;

procedure TNCRSpeedButton.SetTransparency(aValue: boolean);
begin
  FTransparent := aValue;
  Invalidate;
end;

{TGlyphCoordinates}

procedure TGlyphCoordinates.SetX(aX: integer);
begin
  FX := aX;
  if Assigned(FOnChange) then
       FOnChange(self);
end;

procedure TGlyphCoordinates.SetY(aY: integer);
begin
  FY := aY;
  if Assigned(FOnChange) then
       FOnChange(self);
end;

function TGlyphCoordinates.GetX: integer;
begin
  result := FX;
end;

function TGlyphCoordinates.GetY: integer;
begin
  result := FY;
end;

procedure TGlyphCoordinates.assign(aValue: TPersistent);
begin
  if aValue is TGlyphCoordinates then begin
    FX := TGlyphCoordinates(aValue).FX;
    FY := TGlyphCoordinates(aValue).FY;
  end else
    inherited;
end;



end.