qiushuifuye 2015-08-04 03:31 采纳率: 100%
浏览 2176
已采纳

Delphi DLL数据及窗体调用

DLL工程相关代码如下:
library DLLUSERS;
uses
Windows,
ADODB,
Dialogs,
Forms,
SysUtils,
Classes,
U_DataModule in 'U_DataModule.pas' {DataModule1: TDataModule},
U_Users in 'U_Users.pas' {Frm_Users},
U_Initialize in 'U_Initialize.pas';
{$R *.res}

function GetForm(ClassName: PChar; DM: TDataModule1): TFormClass; stdcall;
begin
DataModule1 := DM;
Result:=TFormClass(FindClass(ClassName));
end;

procedure InitDLL(DM: TDataModule1); stdcall;
begin
DataModule1:=DM;
end;

exports
GetForm,InitDLL,SetUseName;
begin
end.

DLL公共单元代码如下:
unit U_Initialize;
{DLL公共单元UNIT}
interface

function GetUseName: PChar; stdcall;
procedure SetUseName(SName: PChar); stdcall;

var
StrName: PChar;

implementation

uses
U_DataModule, ActiveX;

function GetUseName: PChar; stdcall;
begin
Result:=StrName;
end;

procedure SetUseName(SName: PChar); stdcall;
begin
StrName:=SName;
end;

initialization
CoInitialize(nil);
DataModule1 := TDataModule1.Create(nil);
finalization
DataModule1.Free;
CoUninitialize;

end.

DLL数据模块代码:
unit U_DataModule;
{数据模块}
interface

uses
SysUtils, Classes, DB, ADODB;

type
TDataModule1 = class(TDataModule)
ADOCNT: TADOConnection;
private
{ Private declarations }
public
{ Public declarations }
end;

var
DataModule1: TDataModule1;

implementation

{$R *.dfm}

end.

DLL内部窗体代码:
unit U_Users;
{DLL内部窗体}
interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DBGridEhGrouping, ComCtrls, GridsEh, DBGridEh, ExtCtrls,
RzPanel, Menus, ADODB, DB, EhlibCDS, EhlibADO, Comobj, DBGridEhImpExp,
U_DataModule;

type
TFrm_Users = class(TForm)
MainMenu1: TMainMenu;
mmAdd: TMenuItem;
mmEdit: TMenuItem;
mmDelete: TMenuItem;
mmRight: TMenuItem;
mmFind: TMenuItem;
mmDataOut: TMenuItem;
mmClose: TMenuItem;
RzGroupBox1: TRzGroupBox;
DBGridEhUsers: TDBGridEh;
StatusBar1: TStatusBar;
SaveDialog1: TSaveDialog;
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
ADOUsers,ADODelete:TADOQuery;
DSUsers: TDataSource;
{ Public declarations }
end;

var
Frm_Users: TFrm_Users;

implementation

uses
U_Initialize;

{$R *.dfm}

procedure TFrm_Users.FormCreate(Sender: TObject);
begin
Font.Name:='Arial';
ADOUsers:=TADOQuery.Create(nil);
ADODelete:=TADOQuery.Create(nil);
DSUsers:=TDataSource.Create(nil);
ADOUsers.Connection:=DataModule1.ADOCNT;
ADODelete.Connection:=DataModule1.ADOCNT;
//设置文件类型列表和默认文件类型
SaveDialog1.Filter:='Text files (*.txt)|*.TXT|Comma separated values (*.csv)|*.CSV|HTML file (*.htm)|*.HTM|Rich Text Format (*.rtf)|*.RTF|Microsoft Excel Workbook (*.xls)|*.XLS';
SaveDialog1.FilterIndex:=0;
end;

procedure TFrm_Users.FormShow(Sender: TObject);
begin
StrName:=GetUseName;
with ADOUsers do
begin
Close;
SQL.Clear;
if String(StrName)='alsaby' then
SQL.Add('select a.*,b.Person_Name,c.Partment_Name from t_User a '+
'left join t_Person b on a.User_PersonId=b.Person_Id '+
'left join t_Partment c on a.User_PartmentId=c.Partment_Id '+
'order by a.User_Name') else
if String(StrName)='admin' then
SQL.Add('select a.*,b.Person_Name,c.Partment_Name from t_User a '+
'left join t_Person b on a.User_PersonId=b.Person_Id '+
'left join t_Partment c on a.User_PartmentId=c.Partment_Id '+
'where a.User_Name<>''alsaby'' order by a.User_Name') else

SQL.Add('select a.*,b.Person_Name,c.Partment_Name from t_User a '+
'left join t_Person b on a.User_PersonId=b.Person_Id '+
'left join t_Partment c on a.User_PartmentId=c.Partment_Id '+
'where a.User_Name<>''alsaby'' and a.User_Name<>''admin'' order by a.User_Name');
Open;
end;
DSUsers.DataSet:=ADOUsers;
DBGridEhUsers.DataSource:=DSUsers;
StatusBar1.Panels[1].Text:=IntToStr(ADOUsers.RecordCount) +' 条数据。';
end;

procedure TFrm_Users.FormClose(Sender: TObject; var Action: TCloseAction);
begin
ADOUsers.Close;
ADOUsers.Destroy;
ADODelete.Close;
ADODelete.Destroy;
DSUsers.Destroy;
Action:=caFree;
end;

initialization
RegisterClass(TFrm_Users);
finalization
UnRegisterClass(TFrm_Users);
end.

主程序调用DLL代码:
unit U_Main;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, ImgList, ComCtrls, ADODB, DB, jpeg, ExtCtrls, RzPanel,
RzSplit, RzTreeVw, U_DataModule;

type
TInitDLL = procedure(DM: TFrm_DataModule); stdcall;
TSetUseName = procedure(SName: PChar); stdcall;
TGetForm = function(ClassName: PChar; DM: TFrm_DataModule): TFormClass; stdcall;
TFrm_Main = class(TForm)
MainMenu1: TMainMenu;
mmSysFlies: TMenuItem;
mmUserChange: TMenuItem;
N2: TMenuItem;
mmExit: TMenuItem;
N1: TMenuItem;
mmBakRecover: TMenuItem;
mmSysUser: TMenuItem;
N5: TMenuItem;
StatusBar1: TStatusBar;
OpenDialog1: TOpenDialog;
ImageList1: TImageList;
procedure FormCreate(Sender: TObject);
procedure mmSysUserClick(Sender: TObject);
private
{ Private declarations }
public
UName: String;
{ Public declarations }
end;

var
Frm_Main: TFrm_Main;
implementation

uses
U_Public;

{$R *.dfm}

procedure TFrm_Main.FormCreate(Sender: TObject);
begin
Font.Name:='Arial';
UName:=Frm_DataModule.ADO_User.FieldByName('User_Name').AsString;
end;

procedure TFrm_Main.mmSysUserClick(Sender: TObject);
var
DLLName: String;
DLLHandle: THandle;
FarProc: TFarProc;
Form: TForm;
SetUseName: TSetUseName;
GetForm: TGetForm;
InitDLL: TInitDLL;
begin
GetDir(0,DLLName);
DLLName := DLLName + '\DLLUSERS.dll';
DLLHandle:= SafeLoadLibrary(DLLName);
if DLLHandle > 0 then
Try
FarProc := GetProcAddress(DLLHandle, 'InitDLL');
if FarProc<>nil then
begin
InitDLL := TInitDLL(FarProc);
InitDLL(Frm_DataModule);
end;

  FarProc := GetProcAddress(DLLHandle, 'SetUseName');
  if FarProc<>nil then
  begin
    SetUseName := TSetUseName(FarProc);
    SetUseName(PChar(Trim(UName)));
  end;

  FarProc := GetProcAddress(DLLHandle, 'GetForm');
  if FarProc<>nil then
  begin
    GetForm := TGetForm(FarProc);
    Form := GetForm('TFrm_Users', Frm_DataModule).Create(nil);
    Form.ShowModal;
    FreeAndNil(Form);
  end;
Finally
  FreeLibrary(DLLHandle);
End

else
ShowMessage(DLLName+'文件不存在!');

end;

end.


以上第一次运行数据都是可以正确显示的,可是关闭调用出来的DLL内部窗体后,再次调用就出现错误了,错误提示为Read of address 00000008,这是为什么呢?

  • 写回答

2条回答 默认 最新

  • lyhoo163 2015-08-11 00:18
    关注

    function GetForm(ClassName: PChar; DM: TDataModule1): TFormClass; stdcall;
    begin
    DataModule1 := DM;
    Result:=TFormClass(FindClass(ClassName));
    end;

    procedure InitDLL(DM: TDataModule1); stdcall;
    begin
    DataModule1:=DM;
    end;

    传递了对象,是不可取的。改成传递TADOConnection的连接字符 ConnectionString,就可以了。

    本回答被题主选为最佳回答 , 对您是否有帮助呢?
    评论
查看更多回答(1条)

报告相同问题?

悬赏问题

  • ¥150 求 小魔指游戏板整合模拟软件
  • ¥20 你好,我想问下easyExcel下拉多选,或者复选框可以实现吗
  • ¥20 双非跨考工科哪个专业和方向就业前景好?
  • ¥20 求会6sv辐射传输模型,辅导(可py6s🙏🏻有偿
  • ¥15 .xla后缀的文件拖到excel里什么内容也没有怎么办
  • ¥20 Workbench中Mechanical打不开、闪退是什么原因?
  • ¥240 MapReduce应用实践 学生课程
  • ¥15 hlss视频显示AUTHORITY_INVALID
  • ¥15 MAX9296A+MAX96717,美信gmsl解串有人做过吗?
  • ¥15 求帮我解决一下inode 爆满的问题(有偿)