这个dll有什么错误? ( 积分: 100 )

  • 主题发起人 主题发起人 kwmxw
  • 开始时间 开始时间
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没有释放,请问该如何解决?!
 
看的头晕,楼主能不能将出错的地方的些代码放上来,这样都不知从何看起啊
 
贴的太长,只看了这一句“调用后出现“Access violation at address”错误!如果
去掉 freelibrary(UD); 则能正常显示,但是dll没有释放,请问该如何解决?! ”
一般来说,就是里面有代码还依赖于它,不能释放,我的代码里也有些如是,好象没什么好的解决办法,只有不释放,等程序运行完后程序终止自己释放
 
同样问题,期待!
 
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 t....or use fastmm4
 
我没有用string
 
procedure ShowDropBin(mymenu: [red]TMenuItem[/red]);stdcall;

你没有用string?仔细看你的声明,再仔细看英文注释的这一段:
if your DLL exports any procedures or
functions that pass strings as parameters or function results. This
[red]applies to[/red] all strings passed to and from your DLL--[red]even those that
are nested in records and classes[/red].
 
里面的代码质量实在不敢恭维,定义的变量不用,传入的参数也没有见哪使用了.
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);
end else begin
frm_drop.Close;
end;
end;

给你排错都不知从何下手.
 
代码重新编辑过,sharemem也加上但还是在freelibrary(ud)过程中出现错误!
 
去掉ShoareMem就可以了。
 
ShoareMem,是在工程单元里加的
 
后退
顶部