K
kwmxw
Unregistered / Unconfirmed
GUEST, unregistred user!
*******dll部分****************
library dropform;
{ Important note about DLL memory management: ShareMem must be the
first unit in your library's USES clause AND your project's (select
Project-View Source) USES clause if your DLL exports any procedures or
functions that pass strings as parameters or function results. This
applies to all strings passed to and from your DLL--even those that
are nested in records and classes. ShareMem is the interface unit to
the BORLNDMM.DLL shared memory manager, which must be deployed along
with your DLL. To avoid using BORLNDMM.DLL, pass string information
using PChar or ShortString parameters. }
uses
sharemem,
SysUtils,
Classes,
dropunit in 'dropunit.pas' {frm_drop};
exports
ShowDropBin;
{$R *.res}
begin
end.
unit dropunit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, ExtCtrls, ActiveX, ComObj, StdCtrls, Buttons, Mask, ComCtrls,
jpeg;
type
Tfrm_drop = class(TForm,IDropTarget)
Image1: TImage;
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;
// 显然,不怕编译警告,可以忽略下面四个别名声明。
function IDropTarget.DragEnter=DragEnter;
//function IDropTarget.DragOver=DragOver;
function IDropTarget.DragLeave=DragLeave;
function IDropTarget.Drop=Drop;
// 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
frm_drop: Tfrm_drop;
procedure ShowDropBin(mymenu: TMenuItem);stdcall;
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(mymenu: TMenuItem);stdcall;
type Tpopsub= array of Tmenuitem;
var
pop:Tpopupmenu;
i,j:integer;
popsub,menusub:Tpopsub;
begin
if not Assigned(frm_drop) then
begin
frm_drop := Tfrm_drop.CreateParented(GetDesktopWindow);
pop:=Tpopupmenu.Create(nil);
setlength(popsub,mymenu.Count);
for I := 0 to mymenu.count-1 do
begin
popsub:=Tmenuitem.Create(nil);
popsub.Caption:=mymenu.Caption;
popsub.Tag:=mymenu.Tag;
popsub.Checked:=mymenu.Checked;
popsub.OnClick:=mymenu.OnClick
if mymenu.Items.Count>0 then
begin
setlength(menusub,mymenu.Items.Count);
for j := 0 to mymenu.Items.Count - 1 do
begin
menusub[j]:=Tmenuitem.Create(nil);
menusub[j].Checked:=mymenu.Items[j].Checked;
menusub[j].Caption:=mymenu.Items[j].Caption;
menusub[j].Tag:=mymenu.Items[j].Tag;
menusub[j].OnClick:=mymenu.Items[j].OnClick;
end;
popsub.Add(menusub);
end;
pop.Items.Add(popsub);
end;
frm_drop.PopupMenu:=pop;
end else begin
frm_drop.Close;
end;
end;
constructor Tfrm_drop.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Left:=800;
Top:=200;
Width:=40;
Height:=40;
end;
procedure Tfrm_drop.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 Tfrm_drop.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,80,LWA_ALPHA or LWA_COLORKEY);
end;
// 设置为接受拖拽
OleCheck(RegisterDragDrop(Handle, Self));
end;
procedure Tfrm_drop.DestroyWnd;
begin
if HandleAllocated then RevokeDragDrop(Handle);
inherited DestroyWnd;
end;
function Tfrm_drop.DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
// 也可以在此判断是否接受拖拽,修改 dwEffect 可以得到不同的效果 ...
dwEffect:=DROPEFFECT_COPY;
Result := S_OK;
end;
function Tfrm_drop.IDropTarget_DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
dwEffect:=DROPEFFECT_COPY;
Result:=S_OK;
end;
function Tfrm_drop.DragLeave: HResult; stdcall;
begin
Result:=S_OK;
end;
function Tfrm_drop.Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
dwEffect:=DROPEFFECT_NOne;
Result:=S_OK;
end;
procedure Tfrm_drop.DoClose(var Action: TCloseAction);
begin
Action := caFree;
frm_drop:=nil;
end;
procedure Tfrm_drop.WMNCHitTest(var Msg:TWMNCHitTest);
begin
if GetAsyncKeyState(vk_lbutton)<0 then
Msg.Result:=HTCAPTION
else
Msg.Result := HTCLIENT;
end;
initialization
OleInitialize(nil);
// 为兼容 Win9x
User32ModH := GetModuleHandle('User32.dll');
if User32ModH <> 0 then @SetLayeredWindowAttributes := GetProcAddress(User32ModH, 'SetLayeredWindowAttributes');
finalization
OleUninitialize;
end.
*******动态调用dll部分**********************************
program client;
uses
sharemem,
Forms,
clientmain in 'clientmain.pas' {Frm_client},
popxml in 'popxml.pas',
treexml in 'treexml.pas';
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TFrm_client, Frm_client);
Application.Run;
end.
procedure TFrm_client.Button1Click(Sender: TObject);
type TShowDropBin=procedure(mymenu:TMenuItem);stdcall;
var
ud:Thandle;
PShowDropBin:TShowDropBin;
begin
UD:=LoadLibrary(pchar(extractfilepath(paramstr(0))+'Dll/dropform.dll'));
try
if UD<>0 then
try
Pshowdropbin:=GetProcAddress(UD,pchar('ShowDropBin'));
Pshowdropbin(frm_client.PopupMenu1.Items);
except
on e:exception do
showmessage('调用失败!'+#13+e.Message);
end;
finally
freelibrary(UD);
end;
end;
调用后出现“Access violation at address”错误!如果
去掉 freelibrary(UD); 则能正常显示,但是dll没有释放,请问该如何解决?!
library dropform;
{ Important note about DLL memory management: ShareMem must be the
first unit in your library's USES clause AND your project's (select
Project-View Source) USES clause if your DLL exports any procedures or
functions that pass strings as parameters or function results. This
applies to all strings passed to and from your DLL--even those that
are nested in records and classes. ShareMem is the interface unit to
the BORLNDMM.DLL shared memory manager, which must be deployed along
with your DLL. To avoid using BORLNDMM.DLL, pass string information
using PChar or ShortString parameters. }
uses
sharemem,
SysUtils,
Classes,
dropunit in 'dropunit.pas' {frm_drop};
exports
ShowDropBin;
{$R *.res}
begin
end.
unit dropunit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, ExtCtrls, ActiveX, ComObj, StdCtrls, Buttons, Mask, ComCtrls,
jpeg;
type
Tfrm_drop = class(TForm,IDropTarget)
Image1: TImage;
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;
// 显然,不怕编译警告,可以忽略下面四个别名声明。
function IDropTarget.DragEnter=DragEnter;
//function IDropTarget.DragOver=DragOver;
function IDropTarget.DragLeave=DragLeave;
function IDropTarget.Drop=Drop;
// 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
frm_drop: Tfrm_drop;
procedure ShowDropBin(mymenu: TMenuItem);stdcall;
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(mymenu: TMenuItem);stdcall;
type Tpopsub= array of Tmenuitem;
var
pop:Tpopupmenu;
i,j:integer;
popsub,menusub:Tpopsub;
begin
if not Assigned(frm_drop) then
begin
frm_drop := Tfrm_drop.CreateParented(GetDesktopWindow);
pop:=Tpopupmenu.Create(nil);
setlength(popsub,mymenu.Count);
for I := 0 to mymenu.count-1 do
begin
popsub:=Tmenuitem.Create(nil);
popsub.Caption:=mymenu.Caption;
popsub.Tag:=mymenu.Tag;
popsub.Checked:=mymenu.Checked;
popsub.OnClick:=mymenu.OnClick
if mymenu.Items.Count>0 then
begin
setlength(menusub,mymenu.Items.Count);
for j := 0 to mymenu.Items.Count - 1 do
begin
menusub[j]:=Tmenuitem.Create(nil);
menusub[j].Checked:=mymenu.Items[j].Checked;
menusub[j].Caption:=mymenu.Items[j].Caption;
menusub[j].Tag:=mymenu.Items[j].Tag;
menusub[j].OnClick:=mymenu.Items[j].OnClick;
end;
popsub.Add(menusub);
end;
pop.Items.Add(popsub);
end;
frm_drop.PopupMenu:=pop;
end else begin
frm_drop.Close;
end;
end;
constructor Tfrm_drop.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Left:=800;
Top:=200;
Width:=40;
Height:=40;
end;
procedure Tfrm_drop.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 Tfrm_drop.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,80,LWA_ALPHA or LWA_COLORKEY);
end;
// 设置为接受拖拽
OleCheck(RegisterDragDrop(Handle, Self));
end;
procedure Tfrm_drop.DestroyWnd;
begin
if HandleAllocated then RevokeDragDrop(Handle);
inherited DestroyWnd;
end;
function Tfrm_drop.DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
// 也可以在此判断是否接受拖拽,修改 dwEffect 可以得到不同的效果 ...
dwEffect:=DROPEFFECT_COPY;
Result := S_OK;
end;
function Tfrm_drop.IDropTarget_DragOver(grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
dwEffect:=DROPEFFECT_COPY;
Result:=S_OK;
end;
function Tfrm_drop.DragLeave: HResult; stdcall;
begin
Result:=S_OK;
end;
function Tfrm_drop.Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; stdcall;
begin
dwEffect:=DROPEFFECT_NOne;
Result:=S_OK;
end;
procedure Tfrm_drop.DoClose(var Action: TCloseAction);
begin
Action := caFree;
frm_drop:=nil;
end;
procedure Tfrm_drop.WMNCHitTest(var Msg:TWMNCHitTest);
begin
if GetAsyncKeyState(vk_lbutton)<0 then
Msg.Result:=HTCAPTION
else
Msg.Result := HTCLIENT;
end;
initialization
OleInitialize(nil);
// 为兼容 Win9x
User32ModH := GetModuleHandle('User32.dll');
if User32ModH <> 0 then @SetLayeredWindowAttributes := GetProcAddress(User32ModH, 'SetLayeredWindowAttributes');
finalization
OleUninitialize;
end.
*******动态调用dll部分**********************************
program client;
uses
sharemem,
Forms,
clientmain in 'clientmain.pas' {Frm_client},
popxml in 'popxml.pas',
treexml in 'treexml.pas';
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TFrm_client, Frm_client);
Application.Run;
end.
procedure TFrm_client.Button1Click(Sender: TObject);
type TShowDropBin=procedure(mymenu:TMenuItem);stdcall;
var
ud:Thandle;
PShowDropBin:TShowDropBin;
begin
UD:=LoadLibrary(pchar(extractfilepath(paramstr(0))+'Dll/dropform.dll'));
try
if UD<>0 then
try
Pshowdropbin:=GetProcAddress(UD,pchar('ShowDropBin'));
Pshowdropbin(frm_client.PopupMenu1.Items);
except
on e:exception do
showmessage('调用失败!'+#13+e.Message);
end;
finally
freelibrary(UD);
end;
end;
调用后出现“Access violation at address”错误!如果
去掉 freelibrary(UD); 则能正常显示,但是dll没有释放,请问该如何解决?!