FlashGet炫彩

最新推荐文章于 2017-11-08 13:25:00 发布

ljah

最新推荐文章于 2017-11-08 13:25:00 发布

阅读量859

点赞数

分类专栏： DELPHI模块文章标签： function constructor initialization user action delphi

本文链接：https://blog.csdn.net/ljah/article/details/959734

版权

DELPHI模块专栏收录该内容

8 篇文章 0 订阅

订阅专栏

unit Unit1;

interface

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

type
TfrmDropBin = class(TForm, IDropTarget)
    Label1: TLabel;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
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 := 82;
Height := 82;
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;

procedure TfrmDropBin.Button1Click(Sender: TObject);
begin
Close;// showmessage('ddddddd');
end;

initialization
OleInitialize(nil);
// 为兼容 Win9x
User32ModH := GetModuleHandle('User32.dll');
if User32ModH <> 0 then @SetLayeredWindowAttributes := GetProcAddress(User32ModH, 'SetLayeredWindowAttributes');

finalization
OleUninitialize;

end.