{*******************************************************}
{ }
{ 内存映像文件 }
{ }
{ 版权所有 (C) 2008 咏南工作室(陈新光) }
{ }
{*******************************************************}
unit untMapObj;
interface
uses
Windows, SysUtils, Dialogs;
procedure SetMappedObj(const AObj:Pointer);stdcall;
function GetMappedObj:Pointer;stdcall;
procedure Map(const DesiredAccess: DWORD = FILE_MAP_ALL_ACCESS); stdcall;
procedure Unmap(); stdcall;
implementation
const
SExceptionInfo = 'Error in calling MappedObj.dll.';
SMappedObjName = 'RocketGis.MappedObj';
type
PMappedObj = ^TMappedObj;
TMappedObj = packed record
Size: DWORD;
Data: Pointer;
end;
var
HasMapped: Boolean;
MappedObjHandle: THandle;
MappedObj: PMappedObj;
function GetMappedObj:Pointer; stdcall;
begin
Result := MappedObj^.data;
end;
procedure SetMappedObj(const AObj:Pointer);
begin
if not assigned(MappedObj^.Data) then
MappedObj^.Data := AObj;
end;
procedure Map(const DesiredAccess: DWORD); stdcall;
var
LSize: Integer;
begin
try
if HasMapped then exit ;
LSize := Sizeof(TMappedObj);
MappedObjHandle := CreateFileMapping(DWORD($FFFFFFFF),nil, PAGE_READWRITE,0,
LSize,SMappedObjName);
if MappedObjHandle = 0 then RaiseLastOSError();
MappedObj := MapViewOfFile(MappedObjHandle, DesiredAccess, 0, 0, LSize);
if not Assigned(MappedObj) then
begin
CloseHandle(MappedObjHandle);
RaiseLastOSError();
end;
HasMapped := true;
except
on Exception do
MessageDlg(SExceptionInfo,mtError, [mbOk],0);
end;
end;
procedure Unmap(); stdcall;
begin
try
if not HasMapped then exit;
UnmapViewOfFile(MappedObj);
CloseHandle(MappedObjHandle);
HasMapped := False;
except
on Exception do MessageDlg(SExceptionInfo, mtError, [mbOk], 0);
end;
end;
end.
//DLL初始化时建立内存映像文件
//DLL释放时卸载内存映像文件
library MapObj;
uses
Windows,
SysUtils,
Classes,
untMapObj in 'untMapObj.pas';
procedure DllEntryPoint(dwReason: DWORD);
begin
case dwReason of
DLL_PROCESS_ATTACH: Map(FILE_MAP_ALL_ACCESS);
DLL_PROCESS_DETACH: Unmap();
DLL_THREAD_ATTACH: ;
DLL_THREAD_DETACH: ;
end;
end;
exports
Map, Unmap, GetMappedObj, SetMappedObj;
{$R *.res}
begin
DllProc := @DllEntryPoint;
DllProc(DLL_PROCESS_ATTACH);
end.
//把ADOConnection1的指针映射到一个内存映像文件中
procedure TfrmMain.btnDBMapClick(Sender: TObject);
begin
try
SetMappedObj(Pointer(ADOConnection1));
except
Raise Exception.Create('创建区域对象失败');
end;
end;
//DLL从内存映像文件中获取ADOCONNECTION对象的指针
procedure TfrmPlgView.btnGetDBClick(Sender: TObject);
begin
ADOTable1.Connection := TADOConnection(GetMappedObj);
ADOTable1.Active := true;
end;