Lazarus中的透明Panel组件

猫工

Lazarus中没有透明Panel组件，就自己写了一个，经过一番折腾，总算是设计期和运行期都可以正确的透明了。

注意，透明Panel是通过抓取Parent图片的方式实现的，因此Panel下不能放置别的组件，否则会被背景图挡住。

我写了一个具有背景图片功能的Panel组件，可以结合透明Panel一起使用，效果非常不错，详情参考《Lazarus 的具有背景图片的Panel组件》

下面是组件源码

2. unit uTransparentPanel;
4. {$mode objfpc}{$H+}
6. interface
8. uses
9.   Classes, SysUtils, LMessages, Forms, Controls, Graphics, LCLType, types, Windows;
11. type
12.   { TTransparentPanel }
13.   TTransparentPanel = class(TCustomControl)
15.   private
16.     fBuffer: Graphics.TBitmap;
17.     fBufferChanged : boolean;
18.     procedure SetColor(Value: TColor); override;
20.   protected
21.     function getBuffer : Graphics.TBitmap; virtual;
22.     procedure WMWindowPosChanged(var Message: TLMWindowPosChanged); message LM_WINDOWPOSCHANGED;
23.     procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
24.     procedure CreateParams(var Params: TCreateParams);
25.     procedure Paint; override;
26.     procedure Resize; override;
27.     procedure redrawBackgroundBuffer(var buffer : Graphics.TBitmap); virtual;
28.     function getBufferChanged : boolean; virtual;
29.     procedure setBufferChanged(val : boolean); virtual;
30.     procedure Invalidate; override;
32.   public
33.     constructor Create(AOwner : TComponent); override;
34.     destructor Destroy; override;
36.   published
37.     property OnPaint;
38.     property Color;
39.     property Align;
40.     property Height;
41.     property Cursor;
42.     property HelpContext;
43.     property HelpType;
44.     property Hint;
45.     property Left;
46.     property Name;
47.     property Tag;
48.     property Top;
49.     property Width;
50.     property Anchors;
51.     property Constraints;
52.   end;
54. procedure Register;
56. implementation
58. procedure Register;
59. begin
60.   RegisterComponents('aess',[TTransparentPanel]);
61. end;
63. { TTransparentPanel }
65. procedure TTransparentPanel.SetColor(Value: TColor);
66. begin
67.   inherited SetColor(Value);
68.   RecreateWnd(Self);
69. end;
71. function TTransparentPanel.getBuffer: Graphics.TBitmap;
72. begin
73.   Result := fBuffer;
74. end;
76. procedure TTransparentPanel.WMWindowPosChanged(var Message: TLMWindowPosChanged);
77. begin
78.   setBufferChanged(true);
79.   Invalidate;
80.   inherited;
81. end;
83. procedure TTransparentPanel.WMEraseBkgnd(var Message: TLMEraseBkgnd);
84. begin
85.   Message.Result := 1;
86. end;
88. procedure TTransparentPanel.CreateParams(var Params: TCreateParams);
89. begin
90.   inherited CreateParams(Params);
91.   params.exstyle := params.exstyle or WS_EX_TRANSPARENT;
92. end;
94. procedure TTransparentPanel.Paint;
95. begin
96.   if getBufferChanged then
97.   begin
98.     redrawBackgroundBuffer(fBuffer);
99.     setBufferChanged(false);
100.   end;
101.   Canvas.Draw(0, 0, fBuffer);
102.   if assigned(OnPaint) then
103.     OnPaint(Self);
104. end;
106. procedure TTransparentPanel.Resize;
107. begin
108.   setBufferChanged(true);
109.   Invalidate;
110.   inherited Resize;
111. end;
113. procedure TTransparentPanel.redrawBackgroundBuffer(var buffer : Graphics.TBitmap);
114. var
115.   rDest : TRect;
116.   bmp : Graphics.TBitmap;
117. begin
118.   bmp := Graphics.TBitmap.Create;
119.   try
120.     bmp.PixelFormat := pf24bit;
121.     bmp.Width := Parent.Width;
122.     bmp.Height := Parent.Height;
123.     bmp.TransparentColor:= Self.Color;
124.     bmp.Canvas.brush.Color:=TCustomForm(parent).Color;
125.     bmp.Canvas.FillRect(types.rect(0,0,bmp.width,bmp.height));
126.     SendMessage(parent.Handle, WM_PAINT, bmp.Canvas.handle, 0);
127.     Application.ProcessMessages;
128.     buffer.Width:= Self.Width;
129.     buffer.Height := Self.Height;
130.     rDest := types.Rect(0,0,Width, Height);
131.     buffer.Canvas.CopyRect(rDest, bmp.Canvas, BoundsRect);
132.   finally
133.     freeandnil(bmp);
134.   end;//fianlly
135. end;
137. function TTransparentPanel.getBufferChanged: boolean;
138. begin
139.   Result := fBufferChanged;
140. end;
142. procedure TTransparentPanel.setBufferChanged(val: boolean);
143. begin
144.   fBufferChanged := val;
145. end;
147. procedure TTransparentPanel.Invalidate;
148. begin
149.   if assigned(parent) and parent.HandleAllocated then
150.   begin
151.     InvalidateRect(parent.Handle, BoundsRect, true);
152.     inherited Invalidate;
153.   end
154.   else
155.     inherited Invalidate;
156. end;
158. constructor TTransparentPanel.Create(AOwner: TComponent);
159. begin
160.   inherited Create(AOwner);
161.   fBuffer := Graphics.TBitmap.Create;
162.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
163.   csDoubleClicks, csReplicatable];
164.   Width := 200;
165.   Height := 150;
166.   ParentCtl3d := False;
167.   Ctl3D := False;
168.   ParentColor := False;
169.   fBufferChanged:= false;
170.   inherited Color := clWindow;
171. end;
173. destructor TTransparentPanel.Destroy;
174. begin
175.   fBuffer.Free;
176.   inherited Destroy;
177. end;
179. end.

复制代码

转自：http://lc51746.blog.163.com/blog ... romSearchEngine=yes

bruce0829

貓工哥若是能貼一張圖來展示透明效果, 豈不更好 ?
常常看到大陸技術文章都不喜歡貼圖
殊不知千行萬碼都抵不過一張圖的效果
去 google 搜尋, 相同或類似標題的技術文件就有幾十篇
不可能每一篇都下載下來研究測試
甚至很多文章內容跟標題講的不大一樣
(例如標題叫 "黃河之水天上來" ,
內容可能是一篇探討黃河水質的科學研究,
而不是詩詞文學欣賞, 作者跟讀者解讀就不同)
若讀者能看到圖, 就直接知道是不是自己需要的東西

xhua_yu

好东西啊  ！！
辛苦楼主了，收藏。

jixian

Linux下是不透明的