5,928
社区成员




unit UFcall;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TFcall = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Fcall: TFcall;
implementation
{$R *.dfm}
{------------------请注意------------------------------}
//procedure FCrm_BAAGLAPP(App:THandle);stdcall;external 'mydll.dll';
procedure TFcall.Button1Click(Sender: TObject);
type
TShowNls = procedure(App:THandle);stdcall;
var
Th:Thandle;
ShowNls:TShowNls;
Tp:TFarProc;
begin
Th:=LoadLibrary('mydll.dll'); {装载DLL}
if Th>0 then
try
Tp:=GetProcAddress(Th,PChar('FCrm_BAAGLAPP'));
if Tp<>nil then begin
ShowNls:=TShowNls(Tp);
ShowNls(Application.Handle);
end
else
ShowMessage('FCrm_BAAGLAPP过程没有找到');
finally
FreeLibrary(Th); {释放DLL}
end
else
ShowMessage('mydll.dll没有找到');
end;
end.
library MYDLL;
{ 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
SysUtils,
Classes,
Umain in 'Umain.pas' {Fmain};
{$R *.res}
exports
FCrm_BAAGLAPP;
begin
end.
unit Umain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TFmain = class(TForm)
Button1: TButton;
Edit1: TEdit;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
{---看看这里与你的对比---}
procedure FCrm_BAAGLAPP(App: THandle); stdcall;
implementation
{$R *.dfm}
procedure FCrm_BAAGLAPP(App: THandle); stdcall;
var
Fmain: TFmain;
begin
Application.Handle := App;
Fmain:=TFmain.Create(Application);
try
Fmain.ShowModal;
finally
Fmain.Free;
end;
end;
procedure TFmain.Button1Click(Sender: TObject);
begin
{--窗体的按钮单激事件--}
close;
end;
procedure TFmain.FormShow(Sender: TObject);
begin
{--窗体的show事件--}
edit1.Text:='abc';
end;
procedure TFmain.FormCreate(Sender: TObject);
var
i:integer;
begin
{窗体的FormCreate}
for i := 0 to 20 do
ListBox1.Items.Add(inttostr(i));
end;
end.
unit UFcall;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TFcall = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Fcall: TFcall;
implementation
{$R *.dfm}
procedure FCrm_BAAGLAPP(App:THandle);stdcall;external 'mydll.dll';
procedure TFcall.Button1Click(Sender: TObject);
begin
FCrm_BAAGLAPP(Application.Handle);
end;
end.
unit UCrm_BAAGL;
interface
uses
.............
type
TFCrm_BAAGL = class(TForm)
.............................
////var
////FCrm_BAAGL: TFCrm_BAAGL;
procedure FCrm_BAAGLAPP(App: THandle); stdcall;
procedure FCrm_BAAGLSFM(frmAy: array of string; frmStrL: TStringList); stdcall;
implementation
{$R *.dfm}
//***** 窗体初始调用 *****
procedure FCrm_BAAGLAPP(App: THandle); stdcall;
begin
Application.Handle := App;
end;
//***** 窗体初始调用 *****
procedure FCrm_BAAGLSFM(frmAy: array of string; frmStrL: TStringList); stdcall;
var
FCrm_BAAGL: TFCrm_BAAGL;
begin
try
if not Assigned(FCrm_BAAGL) then
////FCrm_BAAGL := TFCrm_BAAGL.Create(Application);
FCrm_BAAGL := TFCrm_BAAGL.Create(nil);//TFCrm_BAAGL创建以nil作为Owner试试
try
userno := frmAy[0];
dllcurdir := frmAy[1];
UserpowerStr := TStringList.Create;
UserpowerStr.CommaText := frmStrL.CommaText;
FCrm_BAAGL.ShowModal;
finally
FCrm_BAAGL.Free;
end;
except
on E: Exception do
MessageDlg('Error in CRMBAAFm: ' +
E.Message, mtError, [mbOK], 0);
end;
end;
//FCrm_BAAGL: TFCrm_BAAGL;---------------------这里注掉
procedure FCrm_BAAGLAPP(App:THandle,frmAy:array of string;frmStrL:TStringList);stdcall;
unit UCRM_MAIN;
interface
uses
................
type
TFZX_MAIN = class(TForm)
MainMenu1: TMainMenu;
G1: TMenuItem;
........
var
FZX_MAIN: TFZX_MAIN;
procedure FCrm_BAAGLAPP(App:THandle,frmAy:array of string;frmStrL:TStringList);stdcall;external '.\HBDLL\DllCrm_BAAGL.dll';
procedure TFZX_MAIN.SM01M02Click(Sender: TObject);
var mainAy : array of string ;
begin
SetLength(mainAy,2);
mainAy[0] := userno ; mainAy[1] := dllcurdir;
FCrm_BAAGLAPP(Application.Handle,mainAy,UserpowerStr);
mainAy := nil ;
end;
第一个封装的窗体源码如下:
///////////////////
library DllCrm_BAAGL;
uses
ShareMem,
SysUtils,
Classes,
UCrm_BAAGL in 'UCrm_BAAGL.pas' {FCrm_BAAGL};
{$R *.res}
function GetDllChildFormBAAGL(Parent:TComponent):TFCrm_BAAGL;stdcall;
begin
Result := TFCrm_BAAGL.Create(Parent);
end;
exports
FCrm_BAAGLAPP;
begin
end.
////////////////////////
unit UCrm_BAAGL;
interface
uses
.............
type
TFCrm_BAAGL = class(TForm)
.............................
var
//FCrm_BAAGL: TFCrm_BAAGL;---------------------这里注掉
procedure FCrm_BAAGLAPP(App:THandle);stdcall;
implementation
{$R *.dfm}
//***** 窗体初始调用 *****
procedure FCrm_BAAGLAPP(App:THandle,frmAy:array of string;frmStrL:TStringList);stdcall;
var
FCrm_BAAGL: TFCrm_BAAGL;//------------这里加回先前注掉的
begin
Application.Handle := App;
try
if not Assigned(FCrm_BAAGL) then
FCrm_BAAGL := TFCrm_BAAGL.Create(Application);
try
userno := frmAy[0] ;
dllcurdir := frmAy[1] ;
UserpowerStr := TStringList.Create;
UserpowerStr.CommaText := frmStrL.CommaText ;
FCrm_BAAGL.ShowModal;
finally
FCrm_BAAGL.Free;
end;
except
on E: Exception do
MessageDlg ('Error in CRMBAAFm: ' +
E.Message, mtError, [mbOK], 0);
end;
end;
unit UCRM_MAIN;
interface
uses
................
type
TFCrm_BAAGLAPP = procedure(App:THandle);stdcall; //申明
TFCrm_BAAGLSFM = procedure FCrm_BAAGLSFM(frmAy:array of string;frmStrL:TStringList);stdcall; //申明
TFZX_MAIN = class(TForm)
MainMenu1: TMainMenu;
G1: TMenuItem;
........
var
FZX_MAIN: TFZX_MAIN;
procedure TFZX_MAIN.SM01M02Click(Sender: TObject);
var mainAy : array of string ;
var
MyFuncA: TFCrm_BAAGLAPP;
MyFuncB: TFCrm_BAAGLSFM;
FPointer: TFarProc;
handle: THandle;
begin
SetLength(mainAy,2);
mainAy[0] := userno ; mainAy[1] := dllcurdir;
hanlde := LoadLibrary(PChar('.\HBDLL\DllCrm_BAAGL.dll')); //装载Library
if handle <> 0 then
begin
FPointer := GetProcAddress(handle, 'FCrm_BAAGLAPP');
if not (FPointer = nil) then
begin
MyFuncA := TFCrm_BAAGLAPP(FPointer);
MyFuncA(Application.Handle);
FreeLibrary(handle);
end;
end;
hanlde := LoadLibrary(PChar('.\HBDLL\DllCrm_BAAGL.dll'));
if handle <> 0 then
begin
FPointer := GetProcAddress(handle, 'FCrm_BAAGLSFM');
if not (FPointer = nil) then
begin
MyFuncB := TFCrm_BAAGLSFM(FPointer);
MyFuncB(mainAy, UserpowerStr);
FreeLibrary(handle);
end;
end;
mainAy := nil ;
end;