/examples/shapedcontrols/unit1.pas

 1unit Unit1; 
 2
 3{$mode objfpc}{$H+}
 4
 5interface
 6
 7uses
 8  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
 9  ExtCtrls;
10
11type
12
13  { TForm1 }
14
15  TForm1 = class(TForm)
16    Button1: TButton;
17    procedure Button1Click(Sender: TObject);
18    procedure FormCreate(Sender: TObject);
19  private
20    { private declarations }
21  public
22    procedure ShapeControl(AControl: TWinControl);
23  end; 
24
25var
26  Form1: TForm1; 
27
28implementation
29
30{$R unit1.lfm}
31
32{ TForm1 }
33
34procedure TForm1.Button1Click(Sender: TObject);
35begin
36  ShapeControl(Self);
37end;
38
39procedure TForm1.FormCreate(Sender: TObject);
40begin
41  Button1.Handle;
42  ShapeControl(Button1);
43end;
44
45procedure TForm1.ShapeControl(AControl: TWinControl);
46var
47  ABitmap: TBitmap;
48  Points: array of TPoint;
49begin
50  ABitmap := TBitmap.Create;
51  ABitmap.Monochrome := True;
52  ABitmap.Width := AControl.Width;
53  ABitmap.Height := AControl.Height;
54  SetLength(Points, 6);
55  Points[0] := Point(0, ABitmap.Height div 2);
56  Points[1] := Point(10, 0);
57  Points[2] := Point(ABitmap.Width - 10, 0);
58  Points[3] := Point(ABitmap.Width, ABitmap.Height div 2);
59  Points[4] := Point(ABitmap.Width - 10, ABitmap.Height);
60  Points[5] := Point(10, ABitmap.Height);
61  with ABitmap.Canvas do
62  begin
63    Brush.Color := clBlack; // transparent color
64    FillRect(0, 0, ABitmap.Width, ABitmap.Height);
65    Brush.Color := clWhite; // mask color
66    Polygon(Points);
67  end;
68  AControl.SetShape(ABitmap);
69  ABitmap.Free;
70end;
71
72end.
73