Author: Tomas Rutkauskas
How to create a transparent TPanel
Answer:
Solve 1:
Particularly note the SetParent bit. It works even with movement. It should even
work in Delphi 1, as it doesn't use the Win32 non-rectangular-window method for
creating transparency. The code is simple so can be easily retro-fitted to any
control that you wished were transparent. I put this together in ten minutes, so it
needs proper testing to make sure it doesn't cause any problems, but here it is.
Create one on a form, and drag it about over some edits, combo boxes etc. (and
TImages and you'll get major flicker).
1 type
2 TTransparentPanel = class(TPanel)
3 private
4 procedure SetParent(AParent: TWinControl); override;
5 procedure WMEraseBkGnd(var message: TWMEraseBkGnd); message WM_EraseBkGnd;
6 protected
7 procedure CreateParams(var Params: TCreateParams); override;
8 procedure Paint; override;
9 public
10 constructor Create(AOwner: TComponent); override;
11 procedure Invalidate; override;
12 end;
13
14 constructor TTransparentPanel.Create(AOwner: TComponent);
15 begin
16 inherited Create(AOwner);
17 ControlStyle := ControlStyle - [csOpaque];
18 end;
19
20 procedure TTransparentPanel.CreateParams(var Params: TCreateParams);
21 begin
22 inherited CreateParams(Params);
23 Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
24 end;
25
26 procedure TTransparentPanel.Paint;
27 begin
28 Canvas.Brush.Style := bsClear;
29 Canvas.Rectangle(0, 0, Width, Height);
30 Canvas.TextOut(Width div 2, Height div 2, 'Transparent');
31 end;
32
33 procedure TTransparentPanel.WMEraseBkGnd(var message: TWMEraseBkGnd);
34 begin
35 {Do Nothing}
36 message.Result := 1;
37 end;
38
39 procedure TTransparentPanel.SetParent(AParent: TWinControl);
40 begin
41 inherited SetParent(AParent);
42 {The trick needed to make it all work! I don't know if changing the parent's
43 style is a good idea, but it only removes the WS_CLIPCHILDREN style which
44 shouldn't cause any problems.}
45 if Parent <> nil then
46 SetWindowLong(Parent.Handle, GWL_STYLE, GetWindowLong
47 (Parent.Handle, GWL_STYLE) and not WS_ClipChildren);
48 end;
49
50 procedure TTransparentPanel.Invalidate;
51 var
52 Rect: TRect;
53 begin
54 Rect := BoundsRect;
55 if (Parent <> nil) and Parent.HandleAllocated then
56 InvalidateRect(Parent.Handle, @Rect, True)
57 else
58 inherited Invalidate;
59 end;
Solve 2:
60 unit TransparentPanel;
61
62 interface
63
64 uses
65 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
66 ExtCtrls;
67
68 type
69 TTransparentPanel = class(TPanel)
70 private
71 { Private declarations }
72 FBackground: TBitmap;
73 procedure WMEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND;
74 protected
75 { Protected declarations }
76 procedure CaptureBackground;
77 procedure Paint; override;
78 public
79 { Public declarations }
80 procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
81 property Canvas;
82 constructor Create(aOwner: TComponent); override;
83 destructor Destroy; override;
84 published
85 { Published declarations }
86 end;
87
88 procedure register;
89
90 implementation
91
92 procedure register;
93 begin
94 RegisterComponents('PBGoodies', [TTransparentPanel]);
95 end;
96
97 procedure TTransparentPanel.CaptureBackground;
98 var
99 canvas: TCanvas;
100 dc: HDC;
101 sourcerect: TRect;
102 begin
103 FBackground := TBitmap.Create;
104 with Fbackground do
105 begin
106 width := clientwidth;
107 height := clientheight;
108 end;
109 sourcerect.TopLeft := ClientToScreen(clientrect.TopLeft);
110 sourcerect.BottomRight := ClientToScreen(clientrect.BottomRight);
111 dc := CreateDC('DISPLAY', nil, nil, nil);
112 try
113 canvas := TCanvas.Create;
114 try
115 canvas.handle := dc;
116 Fbackground.Canvas.CopyRect(clientrect, canvas, sourcerect);
117 finally
118 canvas.handle := 0;
119 canvas.free;
120 end;
121 finally
122 DeleteDC(dc);
123 end;
124 end;
125
126 constructor TTransparentPanel.Create(aOwner: TComponent);
127 begin
128 inherited;
129 ControlStyle := controlStyle - [csSetCaption];
130 end;
131
132 destructor TTransparentPanel.Destroy;
133 begin
134 FBackground.free;
135 inherited;
136 end;
137
138 procedure TTransparentPanel.Paint;
139 begin
140 if csDesigning in ComponentState then
141 inherited
142 {would need to draw frame and optional caption here do not call
143 inherited, the control fills its client area if you do}
144 end;
145
146 procedure TTransparentPanel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
147 begin
148 if Visible and HandleAllocated and not (csDesigning in ComponentState) then
149 begin
150 Fbackground.Free;
151 Fbackground := nil;
152 Hide;
153 inherited;
154 Parent.Update;
155 Show;
156 end
157 else
158 inherited;
159 end;
160
161 procedure TTransparentPanel.WMEraseBkGnd(var msg: TWMEraseBkGnd);
162 var
163 canvas: TCanvas;
164 begin
165 if csDesigning in ComponentState then
166 inherited
167 else
168 begin
169 if not Assigned(FBackground) then
170 Capturebackground;
171 canvas := TCanvas.create;
172 try
173 canvas.handle := msg.DC;
174 canvas.draw(0, 0, FBackground);
175 finally
176 canvas.handle := 0;
177 canvas.free;
178 end;
179 msg.result := 1;
180 end;
181 end;
182
183 end.
Solve 3:
This panel will be transparent only at runtime.
184 { ... }
185 type
186 TMyPopUpTransPanel = class(TPanel)
187 protected
188 procedure CMHitTest(var message: TCMHitTest); message CM_HITTEST;
189 procedure WndProc(var message: TMessage); override;
190 procedure CreateParams(var Params: TCreateParams); override;
191 procedure Paint; override;
192 end;
193 { ... }
194
195 procedure TMyPopUpTransPanel.CMHitTest(var message: TCMHitTest);
196 begin
197 message.Result := Windows.HTNOWHERE;
198 end;
199
200 procedure TMyPopUpTransPanel.WndProc(var message: TMessage);
201 var
202 XControl: TControl;
203 XPos: TPoint;
204 begin
205 if not (csDesigning in ComponentState) and ((message.Msg >= WM_MOUSEFIRST)
206 and (message.Msg <= WM_MOUSELAST)) then
207 begin
208 XPos := ClientToScreen(POINT(TWMMouse(message).XPos, TWMMouse(message).YPos));
209 XControl := Parent.ControlAtPos(POINT(TWMMouse(message).XPos +
210 Left, TWMMouse(message).YPos + Top), true, true);
211 if Assigned(XControl) and (XControl is TWinControl) then
212 begin
213 XPos := TWinControl(XControl).ScreenToClient(XPos);
214 TWMMouse(message).XPos := XPos.X;
215 TWMMouse(message).YPos := XPos.Y;
216 PostMessage(TWinControl(XControl).Handle, message.Msg,
217 message.WParam, message.LParam);
218 end
219 else
220 begin
221 XPos := Parent.ScreenToClient(XPos);
222 TWMMouse(message).XPos := XPos.X;
223 TWMMouse(message).YPos := XPos.Y;
224 PostMessage(Parent.Handle, message.Msg, message.WParam, message.LParam);
225 end;
226 message.Result := 0;
227 end
228 else
229 inherited WndProc(message);
230 end;
231
232 procedure TMyPopUpTransPanel.CreateParams(var Params: TCreateParams);
233 begin
234 inherited CreateParams(Params);
235 if not (csDesigning in ComponentState) then
236 Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
237 end;
238
239 procedure TMyPopUpTransPanel.Paint;
240 var
241 XBitMap: TBitMap;
242 XOldDC: HDC;
243 XRect: TRect;
244 begin
245 if (csDesigning in ComponentState) then
246 inherited Paint
247 else
248 begin
249 XRect := ClientRect;
250 XOldDC := Canvas.Handle;
251 XBitMap := TBitMap.Create;
252 try
253 XBitMap.Height := Height;
254 XBitMap.Width := Width;
255 Canvas.Handle := XBitMap.Canvas.Handle;
256 inherited Paint;
257 RedrawWindow(Parent.Handle, @XRect, 0, RDW_ERASE or RDW_INVALIDATE or
258 RDW_NOCHILDREN or RDW_UPDATENOW);
259 finally
260 Canvas.Handle := XOldDC;
261 Canvas.BrushCopy(XRect, XBitMap, XRect, Color);
262 XBitMap.Free;
263 end;
264 end;
265 end;
|
