來源：Delphi園地
最近有網(wǎng)友問道如何用 Delphi 實(shí)現(xiàn)"網(wǎng)絡(luò)螞蟻"和"FlashGet"的懸浮窗口,筆者對使用
到的相關(guān)技巧做了整理如下:
1.懸浮窗口
Delphi 的 TForm.FormStyle 具有 fsStayOnTop 屬性,但只是對其程序本身而言的,
也就是說只在此應(yīng)用程序本身的窗口中是前端顯示的,其他的程序的窗口仍然可以覆蓋
此類型的窗口。這是應(yīng)為此窗口的父窗口是 TApplication 。要讓懸浮窗口獨(dú)立的顯示
在屏幕前端,應(yīng)在創(chuàng)建窗口時(shí)將其父窗口設(shè)置為"桌面"。
Form2 := TForm2.CreateParented(GetDesktopWindow);
2.允許 Client 區(qū)域拖動窗口
這只要捕獲窗口的 WM_NCHITTEST 消息,將客戶區(qū)HitTest(HTCLIENT)變成標(biāo)題欄
的HitTest(HTCAPTION)就可以了。
3.半透明
Windows2000/XP 給窗口增加了WS_EX_LAYERED 屬性,并通過 API
SetLayeredWindowAttributes(); 來設(shè)置此屬性的詳細(xì)信息。Delphi 6 的 Forms 單元
已經(jīng)支持此窗口屬性。
property AlphaBlend default False; // 是否使用半透明效果
property AlphaBlendValue default 255; // 透明度 0..255
property TransparentColor default False; // 是否使用穿透色
property TransparentColorValue default 0; // 穿透色
(*此功能僅 Windows2000/XP 支持,不要在 Win9x 嘗試此特效)
4.接收來自 Shell 的鼠標(biāo)拖拽
這將使用到 ActiveX 單元的 IDropTarget 接口,并擴(kuò)展你的 Form 類。
TForm2 = class(TForm, IDropTarget)
....
end;
并在窗口擁有句柄后,用 RegisterDragDrop() 注冊成為 DragDrop 接受目標(biāo)。
以下是實(shí)現(xiàn)的代碼:
unit DropBin;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, ExtCtrls, ActiveX, ComObj;
type
TfrmDropBin = class(TForm, IDropTarget)
private
procedure WMNCHitTest(var Msg:TWMNCHitTest); message WM_NCHITTEST;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure DestroyWnd; override;
procedure DoClose(var Action: TCloseAction); override;
// DragDrop 支持
function DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
function IDropTarget_DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
function IDropTarget.DragOver = IDropTarget_DragOver; // 解決 IDropTarget.DragOver 與 TForm.DragOver 沖突問題
function DragLeave: HResult; stdcall;
function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
public
constructor Create(AOwner: TComponent); override;
end;
var
frmDropBin: TfrmDropBin;
procedure ShowDropBin(Sender: TMenuItem);
implementation
{$R *.dfm}
type
// 雖然 Delphi 的 Windows 單元定義了 SetLayeredWindowAttributes(); ( external ‘User32.dll‘ )
// 但為了兼容 Win9x, 不能直接調(diào)用。
TSetLayeredWindowAttributes = function (Hwnd: THandle; crKey: COLORREF; bAlpha: Byte; dwFlags: DWORD): Boolean; stdcall;
var
User32ModH: HMODULE;
SetLayeredWindowAttributes: TSetLayeredWindowAttributes = nil;
procedure ShowDropBin(Sender: TMenuItem);
begin
if Assigned(frmDropBin) then frmDropBin.Close
else begin
frmDropBin := TfrmDropBin.CreateParented(GetDesktopWindow);
end;
end;
constructor TfrmDropBin.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 32;
Height := 32;
end;
procedure TfrmDropBin.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do begin
Style := WS_POPUP or WS_CLIPSIBLINGS {or WS_BORDER};
ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST;
end;
end;
procedure TfrmDropBin.CreateWnd;
begin
inherited CreateWnd;
Visible := True;
// 為 2000/XP 創(chuàng)建半透明、穿透效果
if Assigned(SetLayeredWindowAttributes) then begin
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
SetLayeredWindowAttributes(Handle, clWhite, 128, LWA_ALPHA or LWA_COLORKEY);
end;
// 設(shè)置為接受拖拽
OleCheck(RegisterDragDrop(Handle, Self));
end;
procedure TfrmDropBin.DestroyWnd;
begin
if HandleAllocated then RevokeDragDrop(Handle);
inherited DestroyWnd;
end;
function TfrmDropBin.DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
//
// 也可以在此判斷是否接受拖拽,修改 dwEffect 可以得到不同的效果 ...
//
dwEffect := DROPEFFECT_COPY;
Result := S_OK;
end;
function TfrmDropBin.IDropTarget_DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
dwEffect := DROPEFFECT_COPY;
Result := S_OK;
end;
function TfrmDropBin.DragLeave: HResult; stdcall;
begin
Result := S_OK;
end;
function TfrmDropBin.Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
//
// 處理 dataObj 中包含的拖拽內(nèi)容 ...
//
dwEffect := DROPEFFECT_NONE;
Result := S_OK;
end;
procedure TfrmDropBin.DoClose(var Action: TCloseAction);
begin
Action := caFree;
frmDropBin := nil;
end;
procedure TfrmDropBin.WMNCHitTest(var Msg:TWMNCHitTest);
begin
// 通過 Client 區(qū)拖動窗口
DefaultHandler(Msg);
if Msg.Result = HTCLIENT then
Msg.Result:= HTCAPTION;
end;
initialization
OleInitialize(nil);
// 為兼容 Win9x
User32ModH := GetModuleHandle(‘User32.dll‘);
if User32ModH <> 0 then @SetLayeredWindowAttributes := GetProcAddress(User32ModH, ‘SetLayeredWindowAttributes‘);
finalization
OleUninitialize;
end.
