DLL共享主窗口的ADOCONNECTION

{*******************************************************}
{                                                       }
{       内存映像文件                                    }
{                                                       }
{       版权所有 (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;