1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:

unit GraphButton;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, StdCtrls, Graphics;

type
  TGraphButton = class(TButton)
   Canvas:TCanvas;
   constructor Create(AOwner:TComponent); override;
   destructor Destroy; override;
   procedure Paint;
   procedure RePaint; override;
  private
    FCaption:TCaption;
    FSpacing:integer;
    FBitmap:TBitmap;
    FMargin:integer;
    procedure SetCaption(NewValue:TCaption);
    procedure SetSpacing(NewValue:integer);
    procedure SetBitmap(NewBitmap:TBitmap);
    procedure SetMargin(NewValue:integer);
  published
   property Caption:TCaption read FCaption write SetCaption;
   property Spacing:integer read FSpacing write SetSpacing;
   property Bitmap:TBitmap read FBitmap write SetBitmap;
   property Margin:integer read FMargin write SetMargin;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Standard', [TGraphButton]);
end;

constructor TGraphButton.Create(AOwner:TComponent);
begin
 inherited Create(AOwner);
 Canvas:=TCanvas.Create;
 FBitmap:=TBitmap.Create;
 FSpacing:=4;
 FMargin:=-1;
end;

destructor TGraphButton.Destroy;
begin
 FBitmap.free;
 Canvas.free;
 inherited Destroy;
end;

procedure TGraphButton.SetCaption(NewValue:TCaption);
begin
 FCaption:=NewValue;
 RePaint;
end;

procedure TGraphButton.SetSpacing(NewValue:integer);
begin
 FSpacing:=NewValue;
 RePaint;
end;

procedure TGraphButton.SetBitmap(NewBitmap:TBitmap);
begin
 FBitmap.Assign(NewBitmap);
 RePaint;
end;

procedure TGraphButton.SetMargin(NewValue:integer);
begin
 if NewValue<-1 then NewValue:=-1;
 FMargin:=NewValue;
 RePaint;
end;

procedure TGraphButton.RePaint;
begin
 Paint;
end;

procedure TGraphButton.Paint;
var ABitmap:TBitmap;
    Left:integer;
begin
 inherited Caption:='';
 inherited RePaint;
 ABitmap:=TBitmap.Create;
 if FBitmap<>nil then ABitmap.Assign(FBitmap) else begin
  ABitmap.Width:=1;
  ABitmap.Height:=1;
 end;
 Canvas.Handle:=GetDC(Handle);
 Canvas.Font.Assign(Font);
 with Canvas do begin
  if FMargin<0 then Left:=(Width-(ABitmap.Width+TextWidth(FCaption))) div 2
   else Left:=FMargin;
  Brush.Style:=bsClear;
  Draw(Left,(Height-ABitmap.Height) div 2,ABitmap);
  TextOut(Left+ABitmap.Width+Spacing,
   (Height-TextHeight(FCaption)) div 2,FCaption);
 end;
 ABitmap.Free;
end;

end.