Dll窗体调用解

//Project1==========================================================================

//调用窗体 Begin

unit CMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Menus, ExtCtrls, utchild;

const
 WM_CALLBACK = WM_USER + 100;

type
  TShowForm   = function (App: TApplication; CallProc: Pointer; FormID: Integer; ParentForm: TForm; ParentContralHandle: HWND): Tform; stdcall;
  TActiveForm = function : LongInt; stdcall;
  TCloseForm  = function : LongInt; stdcall;

  TfrmMain = class(TForm)
    MainMenu1: TMainMenu;
    Open1: TMenuItem;
    mmFileOpen: TMenuItem;
    mmFileClose: TMenuItem;
    Panel1: TPanel;
    mmFileOpenFrm: TMenuItem;
    mmFileCloseFrm: TMenuItem;
    Report1: TMenuItem;
    N1111: TMenuItem;
    Panel2: TPanel;
    Change1: TMenuItem;
    procedure mmFileOpenClick(Sender: TObject);
    procedure mmFileCloseClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure mmFileOpenFrmClick(Sender: TObject);
    procedure N1111Click(Sender: TObject);
    procedure Change1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    FLibHandle  : THandle;
    FShowForm   : TShowForm;
    FActiveForm : TActiveForm;
    FCloseForm  : TCloseForm;
    List : TList;
    //FFrm: TForm1;
    procedure CallPostMessage(ID:Integer);
    procedure BackCallMessage(var Msg: TMessage); message WM_CALLBACK;

    procedure WMHotKey(var Msg: TWMHotKey); message WM_HOTKEY;
    function GetSysFocus: Integer;
  public
    { Public declarations }
    procedure WMACTIVATEAPP(var Msg: TMessage); message WM_ACTIVATEAPP;
  end;

var
  frmMain: TfrmMain;
  FFrm: TForm1;
implementation
const id_SnapShot = 115; //定义热键标识符

{$R *.dfm}
procedure TfrmMain.WMHotKey(var Msg: TWMHotKey);
var
  H: THandle;
begin
  if Msg.HotKey = id_SnapShot then
  begin
    H := GetSysFocus;
    while IsWindow(H) and (H <> frmMain.Handle) do
    begin
      SendMessage(H,WM_NEXTDLGCTL,0,0);
      H := GetParent(H);
    end;
  end;
end;

function TfrmMain.GetSysFocus: Integer;
var
  hOtherWin,OtherThreadID,hFocusWin:integer;
begin
  hOtherWin:=GetForegroundWindow;
  OtherThreadID:=GetWindowThreadProcessID(hOtherWin,nil);
  if AttachThreadInput(GetcurrentThreadID,OtherThreadID,True) then
  begin
    hFocusWin:=GetFocus;
    result:=GetFocus;
  if HFocusWin<>0 then
  try
  //
  finally
    AttachThreadInput(GetcurrentThreadID,OtherThreadID,False);
  end;
  end
  else result:=GetFocus;
end;

procedure TfrmMain.WMACTIVATEAPP(var Msg: TMessage);
begin
  if Boolean(Msg.WParam) then
    RegisterHotKey(frmMain.Handle, id_SnapShot, 0, VK_TAB)
  else
    UnRegisterHotKey(frmMain.Handle, id_SnapShot);
end;

procedure CallBackProc(ID:Integer); stdcall;
begin
  frmMain.CallPostMessage(ID);
end;

procedure TfrmMain.CallPostMessage(ID: Integer);
begin
 PostMessage(self.Handle, WM_CALLBACK, ID, 0);
end;

procedure TfrmMain.BackCallMessage(var Msg: TMessage);
begin
 if Msg.Msg = WM_CALLBACK then
 begin
   if Msg.WParam = FLibHandle then
   begin
     FreeLibrary(FLibHandle);
     FLibHandle := 0;
   end;
 end;
end;

procedure TfrmMain.mmFileOpenClick(Sender: TObject);
var
 FarPointer : FarProc;
begin
 if FLibHandle = 0 then
 begin
   try
     FLibHandle := LoadLibrary('Project2.dll');
   except
     FLibHandle := 0;
   end;
   if FLibHandle <> 0 then
   begin
     FarPointer  := GetProcAddress(FLibHandle, 'ShowForm');
     FShowForm   := FarPointer;
     FarPointer  :=  GetProcAddress(FLibHandle, 'ActiveForm');
     FActiveForm := FarPointer;
     FarPointer  := GetProcAddress(FLibHandle, 'CloseForm');
     FCloseForm  := FarPointer;
     if Assigned(FShowForm) then
       //FShowForm(Application, @CallBackProc, FLibHandle, self, panel1.Handle);
       List.add(FShowForm(Application, @CallBackProc, FLibHandle, self, panel1.Handle));
   end;
 end
 else
 begin
   if Assigned(FActiveForm) then
   begin
     FActiveForm;
   end;
 end;
end;

procedure TfrmMain.mmFileCloseClick(Sender: TObject);
begin
 if FLibHandle <> 0 then
   FCloseForm;

end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if FLibHandle <> 0 then
    FCloseForm;
  if assigned(FFrm) then
    FreeAndNil(FFrm);
end;

procedure TfrmMain.mmFileOpenFrmClick(Sender: TObject);
begin
  if not assigned(FFrm) then
  begin
    FFrm := TForm1.Create(nil);
    with FFrm do
    begin
      ParentWindow := panel1.Handle;
      align := alClient;
      BorderStyle := bsNone;
      BorderIcons := [];
    end;
  end;
  FFrm.Show;
end;

procedure TfrmMain.N1111Click(Sender: TObject);
begin
  FFrm.Edit2.Text := 'abc';
 
end;

procedure TfrmMain.Change1Click(Sender: TObject);
begin
  if FFrm.ParentWindow = Panel1.handle then
    FFrm.ParentWindow := Panel2.handle
  else
    FFrm.ParentWindow := Panel1.handle
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  List := TList.Create;
end;

end.
//调用窗体End

//Project2.Dll==========================================================================

library Project2;

{ 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,
  Forms,
  Windows,
  Controls,
  Unit2 in 'Unit2.pas' {frmChild},
  Unit1 in 'Unit1.pas' {frmChildCustomer};

{$R *.res}

//function ShowForm(App: TApplication; CallProc: Pointer; CallID: Integer; ParentForm: TForm; ParentContral: HWND): LongInt; stdcall;
function ShowForm(App: TApplication; CallProc: Pointer; CallID: Integer; ParentForm: TForm; ParentContral: HWND): TForm; stdcall;
begin
 Application   := App;
 @FreeProc     := CallProc;
 ProcID        := CallID;

 frmChild      := TfrmChild.Create(ParentForm);
 frmChild.ParentWindow := ParentContral;
 frmChild.Align := alClient;
 frmChild.BorderStyle := bsNone;
 frmChild.BorderIcons := [];
 //SetWindowLong(frmChild.Handle,GWL_STYLE,GetWindowLong(ParentForm.Handle,GWL_STYLE));

 //Result        := Longint(frmChild);
 Result := frmChild;
 frmChild.Show;
 frmChild.BringToFront;
end;

function ActiveForm: LongInt; stdcall;
begin
 if Assigned(frmChild) then
 begin
   frmChild.BringToFront;
   frmChild.SetFocus;
 end;
 Result := 0;
end;

function CloseForm: LongInt;stdcall;
begin
 if Assigned(frmChild) then
 begin
   frmChild.Close;
 end;
 Result := 0;
end;

exports
 ShowForm,  ActiveForm,  CloseForm;

{Dll Entry Point}
procedure ExitDll(Reason: Integer);
begin
 if Reason = DLL_PROCESS_DETACH then // detaching from process
 begin
   // restore application
   Application := DllApp;
 end;
end;

begin
 // backup application
 DllApp  := Application;
 DllProc := @ExitDll;
end.

 //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, cxStyles, cxCustomData, cxGraphics, cxFilter, cxData,
  cxDataStorage, cxEdit, DB, cxDBData, cxGridLevel, cxClasses, cxControls,
  cxGridCustomView, cxGridCustomTableView, cxGridTableView,
  cxGridDBTableView, cxGrid, ExtCtrls, dxBar, cxLookAndFeels, dxSkinsForm;

type
  TFreeProc = procedure (ProcID: Integer); stdcall;

  TfrmChildCustomer = class(TForm)
    dxBarManager1: TdxBarManager;
    dxBarManager1Bar1: TdxBar;
    dxBarButton1: TdxBarButton;
    dxBarButton2: TdxBarButton;
    dxBarButton3: TdxBarButton;
    dxBarButton4: TdxBarButton;
    dxBarButton5: TdxBarButton;
    dxBarButton6: TdxBarButton;
    dxBarButton7: TdxBarButton;
    Panel1: TPanel;
    cxGrid1DBTableView1: TcxGridDBTableView;
    cxGrid1Level1: TcxGridLevel;
    cxGrid1: TcxGrid;
    dxSkinController1: TdxSkinController;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmChildCustomer: TfrmChildCustomer;
  FreeProc   : TFreeProc;     //if childform is free(close), notify parent process
  ProcID     : Integer;       //handle that is loaded from parent process
  DllApp        : TApplication;  //a copy of dll application

implementation

{$R *.dfm}

procedure TfrmChildCustomer.Button1Click(Sender: TObject);
begin
  close;
end;

procedure TfrmChildCustomer.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  Action := caFree;
end;

procedure TfrmChildCustomer.FormDestroy(Sender: TObject);
begin
  if Assigned(@FreeProc) then
    FreeProc(ProcID);
end;

end.
 //////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Unit1;

type

  TfrmChild = class(TfrmChildCustomer)
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmChild: TfrmChild;

implementation

{$R *.dfm}

end.