網絡螞蟻和FlashGet的懸浮窗口的實現

    最近有網友問道如何用 Delphi 實現"網絡螞蟻"和"FlashGet"的懸浮窗口,筆者對使用
到的相關技巧做了整理如下:

1.懸浮窗口
    Delphi 的 TForm.FormStyle 具有 fsStayOnTop 屬性,但只是對其程序本身而言的,
也就是說只在此應用程序本身的窗口中是前端顯示的,其他的程序的窗口仍然可以覆蓋
此類型的窗口。這是應為此窗口的父窗口是 TApplication 。要讓懸浮窗口獨立的顯示
在屏幕前端,應在創建窗口時將其父窗口設置為"桌面"。
   Form2 := TForm2.CreateParented(GetDesktopWindow);

2.允許 Client 區域拖動窗口
    這只要捕獲窗口的 WM_NCHITTEST 消息,將客戶區HitTest(HTCLIENT)變成標題欄
的HitTest(HTCAPTION)就可以了。

3.半透明
    Windows2000/XP 給窗口增加了WS_EX_LAYERED 屬性,並通過 API
SetLayeredWindowAttributes(); 來設置此屬性的詳細信息。Delphi 6 的 Forms 單元
已經支持此窗口屬性。
    property AlphaBlend default False;       // 是否使用半透明效果
    property AlphaBlendValue default 255;   // 透明度 0..255
    property TransparentColor default False;   // 是否使用穿透色
    property TransparentColorValue default 0;  // 穿透色
    (*此功能僅 Windows2000/XP 支持,不要在 Win9x 嘗試此特效)

4.接收來自 Shell 的鼠標拖拽
    這將使用到 ActiveX 單元的 IDropTarget 接口,並擴展你的 Form 類。
      TForm2 = class(TForm, IDropTarget)
       ....
      end;
並在窗口擁有句柄後,用 RegisterDragDrop() 注冊成為 DragDrop 接受目標。

以下是實現的代碼:

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, 不能直接調用。
  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 創建半透明、穿透效果
  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;
  // 設置為接受拖拽
  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 中包含的拖拽內容 ...
  //
  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 區拖動窗口
  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.

作者主頁: delphibbs.com/">http://oopsware.delphibbs.com/

 -----  End of File -----