最近有网友问道如何用 Delphi 实现网络蚂蚁和FlashGet的悬浮窗口笔者对使用到的相关技巧做了整理如下:
悬浮窗口
Delphi 的 TFormFormStyle 具有 fsStayOnTop 属性但只是对其程序本身而言的也就是说只在此应用程序本身的窗口中是前端显示的其他的程序的窗口仍然可以覆盖此类型的窗口这是应为此窗口的父窗口是 TApplication 要让悬浮窗口独立的显示在屏幕前端应在创建窗口时将其父窗口设置为桌面
Form := TFormCreateParented(GetDesktopWindow);
允许 Client 区域拖动窗口
这只要捕获窗口的 WM_NCHITTEST 消息将客户区HitTest(HTCLIENT)变成标题栏的HitTest(HTCAPTION)就可以了
半透明
Windows/XP 给窗口增加了WS_EX_LAYERED 属性并通过 APISetLayeredWindowAttributes(); 来设置此属性的详细信息Delphi 的 Forms 单元已经支持此窗口属性
property AlphaBlend default False; // 是否使用半透明效果
property AlphaBlendValue default ; // 透明度
property TransparentColor default False; // 是否使用穿透色
property TransparentColorValue default ; // 穿透色
(*此功能仅 Windows/XP 支持不要在 Winx 尝试此特效)
接收来自 Shell 的鼠标拖拽
这将使用到 ActiveX 单元的 IDropTarget 接口并扩展你的 Form 类
TForm = 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 IDropTargetDragOver = IDropTarget_DragOver; // 解决 IDropTargetDragOver 与 TFormDragOver 沖突问题
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 Userdll )
// 但为了兼容 Winx 不能直接调用
TSetLayeredWindowAttributes = function (Hwnd: THandle; crKey: COLORREF; bAlpha: Byte; dwFlags: DWORD): Boolean; stdcall;
var
UserModH: HMODULE;
SetLayeredWindowAttributes: TSetLayeredWindowAttributes = nil;
procedure ShowDropBin(Sender: TMenuItem);
begin
if Assigned(frmDropBin) then frmDropBinClose
else begin
frmDropBin := TfrmDropBinCreateParented(GetDesktopWindow);
end;
end;
constructor TfrmDropBinCreate(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := ;
Height := ;
end;
procedure TfrmDropBinCreateParams(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 TfrmDropBinCreateWnd;
begin
inherited CreateWnd;
Visible := True;
// 为 /XP 创建半透明穿透效果
if Assigned(SetLayeredWindowAttributes) then begin
SetWindowLong(Handle GWL_EXSTYLE GetWindowLong(Handle GWL_EXSTYLE) or WS_EX_LAYERED);
SetLayeredWindowAttributes(Handle clWhite LWA_ALPHA or LWA_COLORKEY);
end;
// 设置为接受拖拽
OleCheck(RegisterDragDrop(Handle Self));
end;
procedure TfrmDropBinDestroyWnd;
begin
if HandleAllocated then RevokeDragDrop(Handle);
inherited DestroyWnd;
end;
function TfrmDropBinDragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
//
// 也可以在此判断是否接受拖拽修改 dwEffect 可以得到不同的效果
//
dwEffect := DROPEFFECT_COPY;
Result := S_OK;
end;
function TfrmDropBinIDropTarget_DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
dwEffect := DROPEFFECT_COPY;
Result := S_OK;
end;
function TfrmDropBinDragLeave: HResult; stdcall;
begin
Result := S_OK;
end;
function TfrmDropBinDrop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
//
// 处理 dataObj 中包含的拖拽内容
//
dwEffect := DROPEFFECT_NONE;
Result := S_OK;
end;
procedure TfrmDropBinDoClose(var Action: TCloseAction);
begin
Action := caFree;
frmDropBin := nil;
end;
procedure TfrmDropBinWMNCHitTest(var Msg:TWMNCHitTest);
begin
// 通过 Client 区拖动窗口
DefaultHandler(Msg);
if MsgResult = HTCLIENT then
MsgResult:= HTCAPTION;
end;
initialization
OleInitialize(nil);
// 为兼容 Winx
UserModH := GetModuleHandle(Userdll);
if UserModH <> then @SetLayeredWindowAttributes := GetProcAddress(UserModH SetLayeredWindowAttributes);
finalization
OleUninitialize;
end
