Author: Tomas Rutkauskas
How to create a non-rectangular TPanel
Answer:
1 unit ShapedPanel;
2
3 interface
4
5 uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ExtCtrls;
7
8 type
9 TShapedPanel = class(TCustomControl)
10 private
11 { Private declarations }
12 FBorderColor: TColor;
13 IsLoaded: Boolean;
14 FBorderWidth: Integer;
15 FRgn, FRgn2: HRGN;
16 RgnBrush: TBrush;
17 FFIlLColor: TColor;
18 procedure SetFillColor(const Value: TColor);
19 function GetFillColor: TColor;
20 procedure MakeRegion;
21 procedure SetBorderColor(Value: TColor);
22 procedure WMSize(var message: TMessage); message WM_SIZE;
23 protected
24 { Protected declarations }
25 procedure Paint; override;
26 procedure CreateWnd; override;
27 public
28 { Public declarations }
29 constructor Create(AOwner: TComponent); override;
30 destructor Destroy; override;
31 published
32 { Published declarations }
33 property BorderColor: TColor read FBorderColor write SetBorderColor default
34 clBlack;
35 property BorderWidth: Integer read FBorderWidth write FBorderWidth default 2;
36 property FillColor: TColor read GetFillColor write SetFillColor;
37 property Height default 200;
38 property Width default 200;
39 property OnClick;
40 property OnContextPopup;
41 property OnDblClick;
42 property OnEndDock;
43 property OnEndDrag;
44
45 property OnEnter;
46 property OnExit;
47 property OnMouseDown;
48 property OnMouseMove;
49 property OnMouseUp;
50 property OnResize;
51 property OnStartDrag;
52 end;
53
54 procedure register;
55
56 implementation
57
58 procedure register;
59 begin
60 RegisterComponents('EXS', [TShapedPanel]);
61 end;
62
63 constructor TShapedPanel.Create(AOwner: TComponent);
64 begin
65 inherited Create(AOwner);
66 ControlStyle := [csCaptureMouse, csClickEvents, csOpaque, csDoubleClicks];
67 Width := 200;
68 Height := 200;
69 RgnBrush := TBrush.Create;
70 RgnBrush.Color := clBlack;
71 FFillColor := clWhite;
72 IsLoaded := False;
73 FBorderWidth := 2;
74 FBorderColor := clBlack;
75 FRgn := 0;
76 FRgn2 := 0;
77 end;
78
79 destructor TShapedPanel.Destroy;
80 begin
81 DeleteObject(FRgn);
82 DeleteObject(FRgn2);
83 inherited;
84 end;
85
86 procedure TShapedPanel.CreateWnd;
87 begin
88 inherited;
89 MakeRegion;
90 IsLoaded := True;
91 {IsLoaded is to make sure MakeRegion is not called before there is a
92 Handle for this control, but it may not be nessary}
93 end;
94
95 procedure TShapedPanel.MakeRegion;
96 var
97 x4, y2: Integer;
98 FPoints: array[0..5] of TPoint;
99 begin
100 {I moved the Region creation to this procedure so it can be called for WM_SIZE}
101 SetWindowRgn(Handle, 0, False);
102 {this clears the window region}
103 if FRgn <> 0 then
104 begin
105 {Make sure to Always DeleteObject for a Region}
106 DeleteObject(FRgn);
107 DeleteObject(FRgn2);
108 FRgn := 0;
109 FRgn2 := 0;
110 end;
111 x4 := Width div 4;
112 y2 := Height div 2;
113 FPoints[0] := Point(x4, 0);
114 FPoints[1] := Point(Width - x4, 0);
115 FPoints[2] := Point(Width, y2);
116 FPoints[3] := Point(Width - x4, Height);
117 FPoints[4] := Point(x4, Height);
118 FPoints[5] := Point(0, y2);
119 FRgn := CreatePolygonRgn(FPoints, 6, WINDING);
120 SetWindowRGN(Handle, FRgn, True);
121 FRgn2 := CreatePolygonRgn(FPoints, 6, WINDING);
122 {FRgn2 is used for FrameRgn in Paint}
123 end;
124
125 procedure TShapedPanel.WMSize(var message: TMessage);
126 var
127 TmpClr: TColor;
128 begin
129 inherited;
130 if IsLoaded then
131 begin
132 TmpClr := Canvas.Brush.Color;
133 Canvas.Brush.Color := FFillColor;
134 MakeRegion;
135 FillRgn(Canvas.Handle, FRgn2, Canvas.Brush.Handle);
136 Paint;
137 Canvas.Brush.Color := TmpClr;
138 end;
139 end;
140
141 procedure TShapedPanel.Paint;
142 var
143 TmpClr: TColor;
144 begin
145 inherited;
146 if IsLoaded then
147 begin
148 TmpClr := Canvas.Brush.Color;
149 Canvas.Brush.Color := FFillColor;
150 MakeRegion;
151 FillRgn(Canvas.Handle, FRgn2, Canvas.Brush.Handle);
152 FrameRgn(Canvas.Handle, FRgn2, RgnBrush.Handle, FBorderWidth, FBorderWidth);
153 Canvas.Brush.Color := TmpClr;
154 end;
155 end;
156
157 procedure TShapedPanel.SetBorderColor(Value: TColor);
158 begin
159 if FBorderColor <> Value then
160 begin
161 FBorderColor := Value;
162 RgnBrush.Color := FBorderColor;
163 Paint;
164 end;
165 end;
166
167 procedure TShapedPanel.SetFillColor(const Value: TColor);
168 begin
169 if FFillColor <> Value then
170 begin
171 FFillColor := Value;
172 Paint;
173 end
174 end;
175
176 function TShapedPanel.GetFillColor: TColor;
177 begin
178 Result := FFillColor;
179 end;
180
181 end.
|
