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;
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.