抛砖引玉——关于透明Form(50分)

以前看过一些关于制作透明Form的议题，解决方案大概是在CreateParam中
设置WS_EX_TRANSPARENT，并在OnCreate中设置Brush.Style := bsClear。
试了一下，发现并不OK。于是按照这个思路写了一个完整的程序。如下：

－－－－－Unit1.pas－－－－－

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, StdCtrls, ExtCtrls, AppEvnts;

type
TForm1 = class(TForm)
SpeedButton1: TSpeedButton;
Shape1: TShape;
ApplicationEvents1: TApplicationEvents;
procedure FormCreate(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
procedure ApplicationEvents1Deactivate(Sender: TObject);
private
FPaintFlag: Boolean;
procedure WmPaint(var Msg: TMessage); message WM_PAINT;
procedure WmMove(var Msg: TMessage); message WM_MOVE;
procedure WmNcHitTest(var Msg: TWmNcHitTest); message WM_NCHITTEST;
procedure RepaintDesktop;
protected
procedure CreateParams(var Params: TCreateParams); override;
public
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Brush.Style := bsClear;
end;

procedure TForm1.RepaintDesktop;
var R: TRect;
begin
R := Rect(Left, Top, Left+Width, Top+Height);
RedrawWindow(HWND_DESKTOP, @R, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_ALLCHILDREN);
Sleep(300);
FPaintFlag := True;
end;

procedure TForm1.WmPaint(var Msg: TMessage);
begin
if not FPaintFlag then
RepaintDesktop()
else
begin
FPaintFlag := False;
PaintHandler(TWmPaint(Msg));
end;
end;

procedure TForm1.WmMove(var Msg: TMessage);
begin
inherited;
RepaintDesktop();
end;

procedure TForm1.WmNcHitTest(var Msg: TWmNcHitTest);
var Ctrl: TControl;
P: TPoint;
begin
P.x := Msg.XPos;
P.y := Msg.YPos;
P := ScreenToClient(P);
Ctrl := ControlAtPos(P, False);
if Ctrl = SpeedButton1 then
Msg.Result := HTCLIENT
else if Ctrl = Shape1 then
Msg.Result := HTCAPTION
else
Msg.Result := HTNOWHERE;
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
Close();
end;

procedure TForm1.ApplicationEvents1Deactivate(Sender: TObject);
begin
Invalidate();
end;

end.

－－－－－Unit1.dfm－－－－－
object Form1: TForm1
Left = 192
Top = 107
BorderStyle = bsNone
Caption = 'Form1'
ClientHeight = 157
ClientWidth = 301
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Shape1: TShape
Left = 24
Top = 8
Width = 145
Height = 129
Brush.Color = clYellow
Pen.Color = clRed
Pen.Width = 3
Shape = stCircle
end
object SpeedButton1: TSpeedButton
Left = 136
Top = 8
Width = 25
Height = 25
Caption = 'X'
OnClick = SpeedButton1Click
end
object ApplicationEvents1: TApplicationEvents
OnDeactivate = ApplicationEvents1Deactivate
Left = 96
Top = 64
end
end

这个程序基本上已经OK，主要还有两个缺陷：
1、在重画背景时，ReDrawWindow不等重画完就返回，不得不Sleep一下。
但无论Sleep多久都难以保证背景已经重画好。
2、窗口的不可见部分仍然遮挡其他窗口。

后来发现了SetWindowRgn函数，问题一下子变得简单。如下：

－－－－－t1.pas－－－－－
unit t1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ExtCtrls;

type
TForm1 = class(TForm)
Shape1: TShape;
SpeedButton1: TSpeedButton;
procedure FormCreate(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
private
{ Private declarations }
procedure WmNcHitTest(var Msg: TWmNcHitTest); message WM_NCHITTEST;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var Rgn1, Rgn2: HRGN;
begin
with SpeedButton1 do
Rgn1 := CreateRectRgn(Left, Top, Left+Width, Top+Height);
with Shape1 do
Rgn2 := CreateEllipticRgn(Left, Top, Left+Width+1, Top+Height+1);
CombineRgn(Rgn1, Rgn1, Rgn2, RGN_OR);
DeleteObject(Rgn2);
SetWindowRgn(Handle, Rgn1, True);
end;

procedure TForm1.WmNcHitTest(var Msg: TWmNcHitTest);
var Ctrl: TControl;
P: TPoint;
begin
P.x := Msg.XPos;
P.y := Msg.YPos;
P := ScreenToClient(P);
Ctrl := ControlAtPos(P, False);
if Ctrl = SpeedButton1 then
Msg.Result := HTCLIENT
else if Ctrl = Shape1 then
Msg.Result := HTCAPTION
else
Msg.Result := HTNOWHERE;
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
Close();
end;

end.

－－－－－t1.dfm－－－－－
object Form1: TForm1
Left = 192
Top = 107
BorderStyle = bsNone
Caption = 'Form1'
ClientHeight = 212
ClientWidth = 333
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Shape1: TShape
Left = 48
Top = 32
Width = 161
Height = 121
Brush.Color = clYellow
Pen.Color = clRed
Pen.Width = 3
Shape = stEllipse
end
object SpeedButton1: TSpeedButton
Left = 184
Top = 40
Width = 33
Height = 33
Caption = 'X'
OnClick = SpeedButton1Click
end
end

这是制作不规则形状Form的最好方法。但不可用于让背景半透过的情况。
可以观察金山词霸2000的透明提示条，当背景改变时（例如让它遮住时钟），
画面就不同步了。可以说半透明是没有完善解决方案的。

望各路大侠在此不吝赐教，提出不同的见解。

Bacchus: 刚拜读了大作，我没用过词霸2000。
你是要不规则区域内部半透明，还是外部？

以前的那种方法在窗体重画的时候会发生问题，这个方法可以try.

前面提到过的透明窗口问题可能是指窗口的一部分让背景显露，而另一部分
则显示自身的内容；也可能是指象有色玻璃片那样的窗口。
而这两种情况实际上是不同的问题。前者可采用上面的第二个方法完全解决，
而后者则必须先获取背景内容，几乎没有万全之策。
若上面的第一种方法可行，两个问题就可用同一种方式解决。

用VC曾经实现过两幅图像的半透明alpha过渡，具体内容可参见vc星系的文章，
另外，大家可能用过safeclean utility3，它的窗口效果就具有这种特性，作者也在
v星系上贴过帖子，只不过我能力有限，没有实现。如果你能按照那种思想，可能会做得
很圆满，哦，有一个软件也是个例子，叫做windowsfx

>>

win 2k 下可行，
支持透明窗口层次

Winnt Win98 .... impossible
永远只绘制在前台的窗口，也就是说，你无法得到背后的内容，
自然无法混合。当然了，在自己的窗口显示之前保存全部屏幕的
内容，在根据自身的位置混合计算是可以模拟该效果的，但是，
当背景变化后就露馅了。

感谢各位热情关注，每人10分，皆大欢喜。