菜鸟想的纯玻璃，期待大牛们更好的方法来改进

大悟还俗 2012-08-14 10:18:17

胡思乱想

看到360 做的这个，一直以为是WIN7下毛玻璃，认真一看，还不是，因为我发现它在XP下也是可以的，所以就学着玩做了一个

当然菜鸟用了很菜的方法

我现在就把它叫做纯玻璃吧，

这个纯玻璃可以在 XP WIN7 使用，别的没玩过 ……

以下是代码

unit Un_base;

interface

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

type
Tfm_base = class(TForm)
Button1: TButton;
procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure Button1Click(Sender: TObject);
private

public
{ Public declarations }
procedure WMMOVE(var Msg: TMessage); message WM_MOVE;
procedure WMNchist(var Msg: TMessage);message WM_NCHITTEST;

end;

var
fm_base: Tfm_base;

implementation
{$R *.dfm}
var
fm_glass: TForm;
const
Distance:Integer=60;

procedure Tfm_base.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
sc_dragmove = $f012;
begin
releasecapture;
twincontrol(application.mainform).perform(wm_syscommand,sc_dragmove, 0);
end;

procedure Tfm_base.FormCreate(Sender: TObject);
begin
//置顶
SetWindowPos(Handle,HWND_TOPMOST,Left,Top,Width,Height,SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
//镂空
Color := clFuchsia;
TransparentColorValue := clFuchsia;
TransparentColor := True;
BorderStyle:= bsNone;

end;

procedure Tfm_base.WMMOVE(var Msg: TMessage);
begin
Inherited;
SetWindowPos(Handle,HWND_TOPMOST,Left,Top,Width,Height,SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
if Assigned(fm_glass) then begin fm_glass.Top:=Self.Top-Distance;
fm_glass.Left:=Self.Left-Distance;
end;
end;

procedure Tfm_base.FormShow(Sender: TObject);
var
hr :thandle;
begin
fm_glass:=Tform.create(Application);
with fm_glass do begin
BorderStyle:=bsNone;
//Parent:=Self;
Name:='fm_glass';
top:= Self.Top-Distance;
Left:= Self.Left-Distance;
Height:=Self.Height+2*Distance;
Width:=Self.Width+2*Distance;

Color:=RGB(0,0,0);
AlphaBlend:=True;
AlphaBlendValue:=180;
//TransparentColor:=True;//实现镂空
fm_glass.OnMouseDown:=FormMouseDown;

hr:=createroundrectrgn(0,0,width-1,height-1,50,50);
setwindowrgn(handle,hr,true); //给窗体添加自定义消息

Show;
end;
sendmessage(fm_glass.Handle,WM_MOVE,1,0);
sendmessage(fm_glass.Handle,WM_NCHITTEST,1,0);

end;

procedure Tfm_base.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
fm_glass.Free;
end;

procedure Tfm_base.Button1Click(Sender: TObject);
begin
Application.Terminate;
end;

procedure Tfm_base.WMNchist(var Msg: TMessage);
var
MouseX,MouseY: integer;
begin
{ with fm_glass do begin
MouseX := LOWORD(Msg.LParam);
MouseY := HIWORD(Msg.LParam);
if(MouseX >= Left + Width - 5) and (MouseY >= Top + Height - 5) then
Msg.Result := HTBOTTOMRIGHT
else if (MouseX <= Left + 5) and (MouseY <= Top + 3) then
Msg.Result := HTTOPLEFT
else if (MouseX <= Left + 5) and (MouseY<= Top + Height - 5) then
Msg.Result := HTBOTTOMLEFT
else if MouseX >= Left + Width -5 then
Msg.Result := HTRIGHT
else if MouseY >= Top + Height - 5 then
Msg.Result := HTBOTTOM
else if Mousex <= Left + 5 then
Msg.Result := HTLEFT
else if MouseY <= Top + 5 then
Msg.Result := HTTOP
else Inherited;
end; }
end;

end.