创建一个接受 .PNG 图像作为字形的按钮

Question

我试图了解 SpeedButton Glyph 属性的工作原理，我发现该字段声明为：

FGlyph: TObject;

而 property 为：

property Glyph: TBitmap read GetGlyph write SetGlyph stored HasCustomGlyph;

当我尝试创建自己的 SpeedButton 也接受 .PNG 图像时，即使我逐行阅读它，我也无法理解该代码而不是仅 .bmp 个图像。

我第一次想将属性声明为 TPicture 而不是 TBitmap。

有什么方法可以用 Glyph : TPicture 创建 MySpeedButton 吗？

我的尝试如下：

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

和程序：

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

Answer 1

您的 SetGlyph() 需要调用 FGlyph.Assign(Value) 而不是 FGlyph := Value。一定要在构造函数中创建FGlyph，在析构函数中销毁。然后当 Graphic 不为空时，您可以在覆盖 Paint() 中调用绘制图形。

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

第一部分是关于 TSpeedButton 的 Glyph 属性是如何工作的，因为您似乎将其作为问题的一部分提出。

虽然 TSpeedButton 的 FGlyph 字段被声明为 TObject，但您会发现在代码中它实际上包含 TButtonGlyph 的实例。在 TSpeedButton 构造函数中，您会找到行 FGlyph := TButtonGlyph.Create; TSpeedButton 的 Glyph 属性的 setter 和 getter 看起来像这样：

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

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

所以TSpeedButton的Glyph属性实际上访问了TButtonGlyphclass的Glyph属性，一个Vcl.Buttons 中定义的内部 class，其中封装了实际的 TBitMap 和以下属性

property Glyph: TBitmap read FOriginal write SetGlyph;

所以 TButtonGlyph 有一个 TBitMap 字段 FOriginal 而 setter 是这样实现的：

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;

此时重要的是 accepts .PNG 是如何定义的：

能够使用 PNG 图像，并进行一些权衡。
完全支持 PNG图片

对于后者，我相信 Remy Lebeau 的回答是最好的建议。据我所知，内部 class TButtonGylph 使得 OOP 方法（例如具有 png 能力 class 的继承）是不可能的。或者甚至更进一步，按照雷米在评论中的建议去做：第三方组件。

但是如果权衡取舍是可以接受的：

注意 FOriginal.Assign(Value); 已经可以帮助使用 PNG，因为 TPNGImage 的 AssignTo 过程知道如何将自己分配给 TBitMap。有了上面关于 Glyph 属性的了解，我们可以简单地用下面的代码分配一个 PNG：

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

由于位图和 PNG 之间的差异，这可能会忽略 PNG 的 alpha 通道，但是基于来自 Andreas Rejbrand 的answer，有一个部分解决方案：

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;

Answer 3

我创建了一个类似的组件，它是一个接受 TPicture 作为其字形的 SpeedButton。

这是单位。我希望你能从中受益。

    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.

创建一个接受 .PNG 图像作为字形的按钮

Create a button that accepts .PNG images as Glyph

delphi

delphi-10-seattle