Create a button that accepts .PNG images as Glyph

问题:

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;

回答1:

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.

回答2:

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;

回答3:

The first part is about how the Glyph property of TSpeedButton works, as you seem to be asking that as a part of your problem.

While TSpeedButton's FGlyph field is declared as an TObject, you will find that in code it actually contains an instance of TButtonGlyph. In the TSpeedButton constructor you will find the line FGlyph := TButtonGlyph.Create; and the setter and getter for the Glyph property of TSpeedButton look like this:

function TSpeedButton.GetGlyph: TBitmap;
begin
  Result := TButtonGlyph(FGlyph).Glyph;
end;

procedure TSpeedButton.SetGlyph(Value: TBitmap);
begin
  TButtonGlyph(FGlyph).Glyph := Value;
  Invalidate;
end;

So TSpeedButton's Glyph property actually accesses the Glyph property of the TButtonGlyph class, an internal class defined in Vcl.Buttons, which encapsulates - among other things - the actual TBitMap with following property

property Glyph: TBitmap read FOriginal write SetGlyph;

So the TButtonGlyph has an TBitMap field FOriginal and the setter is implemented like this:

procedure TButtonGlyph.SetGlyph(Value: TBitmap);
var
  Glyphs: Integer;
begin
  Invalidate;
  FOriginal.Assign(Value);
  if (Value <> nil) and (Value.Height > 0) then
  begin
    FTransparentColor := Value.TransparentColor;
    if Value.Width mod Value.Height = 0 then
    begin
      Glyphs := Value.Width div Value.Height;
      if Glyphs > 4 then Glyphs := 1;
      SetNumGlyphs(Glyphs);
    end;
  end;
end;

At this point it is important how accepts .PNG is defined:

• Being able to use the PNG image, with some trade-offs.
• Fully supports PNG images

For the latter I believe the answer of Remy Lebeau is the best advice. The internal class TButtonGylph makes OOP approaches like inheritance with png capable class impossible as far as I see. Or even go further and do as Remy suggests in a comment: third-party component.

If trade-offs are acceptable however:

Note the FOriginal.Assign(Value); which can already help in using PNGs, as TPNGImage's AssignTo procedure knows how to assign itself to a TBitMap. With the above known about the Glyph property, we can simply assign a PNG with the following code:

var
  APNG: TPngImage;
begin
  APNG := TPngImage.Create;
  try
    APNG.LoadFromFile('C:\Binoculars.png');
    SpeedButton1.Glyph.Assign(APNG);
  finally
    APNG.Free;
  end;

Due to differences between bitmap and PNG this might however ignore alpha channel of the PNG, but based on an answer from Andreas Rejbrand there is a partial solution for that:

var
  APNG: TPngImage;
  ABMP: TBitmap;
begin
  APNG := TPngImage.Create;
  ABMP := TBitmap.Create;
  try
    APNG.LoadFromFile('C:\Binoculars.png');

    ABMP.SetSize(APNG.Width, APNG.Height);
    ABMP.Canvas.Brush.Color := Self.Color;
    ABMP.Canvas.FillRect(Rect(0, 0, ABMP.Width, ABMP.Height));
    ABMP.Canvas.Draw(0, 0, APNG);

    SpeedButton1.Glyph.Assign(APNG);
  finally
    APNG.Free;
    ABMP.Free;
  end;
end;