Articles   Members Online:
-Article/Tip Search
-News Group Search over 21 Million news group articles.
-Delphi/Pascal
-CBuilder/C++
-C#Builder/C#
-JBuilder/Java
-Kylix
Member Area
-Home
-Account Center
-Top 10 NEW!!
-Submit Article/Tip
-Forums Upgraded!!
-My Articles
-Edit Information
-Login/Logout
-Become a Member
-Why sign up!
-Newsletter
-Chat Online!
-Indexes NEW!!
Employment
-Build your resume
-Find a job
-Post a job
-Resume Search
Contacts
-Contacts
-Feedbacks
-Link to us
-Privacy/Disclaimer
Embarcadero
Visit Embarcadero
Embarcadero Community
JEDI
Links
How to create a non-rectangular TPanel Turn on/off line numbers in source code. Switch to Orginial background IDE or DSP color Comment or reply to this aritlce/tip for discussion. Bookmark this article to my favorite article(s). Print this article
26-Aug-02
Category
VCL-General
Language
Delphi 2.x
Views
54
User Rating
No Votes
# Votes
0
Replies
0
Publisher:
DSP, Administrator
Reference URL:
DKB
			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.


			
Vote: How useful do you find this Article/Tip?
Bad Excellent
1 2 3 4 5 6 7 8 9 10

 

Advertisement
Share this page
Advertisement
Download from Google

Copyright © Mendozi Enterprises LLC