用DLL实现插件处理DEMO

{本程序演示内容：

实现自定义插件功能的处理！ 插件DLL存放程序目录下的Plugins子目录中。}

//第一个插件的项目文件内容

library  Plugins ;

uses
   SysUtils ,
   Classes ,
   PluginsFrm  in  'PluginsFrm.pas'  {FrmPlugins} ;

{$R *.res}
exports
   GetCaption ,  ShowDllForm ;
begin
   //...
end .

//第一个插件项目的表单文件内容

unit  PluginsFrm ;

interface

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

type
   TFrmPlugins  =  class ( TForm )
     Label1 :  TLabel ;
   private
     { Private declarations }
   public
     { Public declarations }
   end ;
   //函数声明，各插件可约定这些过程
function  GetCaption ( aHandle :  tHandle ):  pchar ;  stdcall ;  //取得插件标题
function  ShowDllForm ( aHandle :  THandle ;  ACaption :  string ):  boolean ;  stdcall ;  //显示窗体
var
   FrmPlugins :  TFrmPlugins ;

implementation

{$R *.dfm}

//输出标题

function  GetCaption ( aHandle :  tHandle ):  pchar ;  stdcall ;
begin
   application . Handle  :=  aHandle ;
   Result  :=  '插件演示 01' ;
end ;

//打开窗体

function  ShowDllForm ( aHandle :  THandle ;  ACaption :  string ):  boolean ;
begin
   Result  :=  True ;
   application . Handle  :=  aHandle ;
   with  TFrmPlugins . Create ( application )  do
   begin
     try
       caption  :=  ACaption ;
       showmodal ;
     finally
       free ;
     end ;
   end ;
end ;
end .

//主控程序源码
unit  UnPluginMain ;

interface

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

type
   //定义接口函数类型
   TShowDllForm  =  function ( aHandle :  THandle ;  ACaption :  string ):  boolean ;  stdcall ;  //窗体显示
   TGetCaption  =  function ( aHandle :  tHandle ):  pchar ;  stdcall ;  //取标题,用于菜单项
   //定义TMyPlugin类,存放 Caption、Address,Call信息
   TMyPlugin  =  class
     Caption :  string ;                     //存取加载后的DLL中GetCaption返回的标题
     Address :  THandle ;                    //存取加载后的DLL的句柄
     Call :  Pointer ;                       //存取ShowDllForm函数的句柄,指针类型
   end ;
   //定义结束
   TFrmPluginMain  =  class ( TForm )
     MainMenu1 :  TMainMenu ;
     File1 :  TMenuItem ;
     Exit1 :  TMenuItem ;
     N1 :  TMenuItem ;
     PrintSetup1 :  TMenuItem ;
     Print1 :  TMenuItem ;
     N2 :  TMenuItem ;
     SaveAs1 :  TMenuItem ;
     Save1 :  TMenuItem ;
     Open1 :  TMenuItem ;
     New1 :  TMenuItem ;
     Plugins1 :  TMenuItem ;
     Memo1 :  TMemo ;
     procedure  FormCreate ( Sender :  TObject );
     procedure  FormDestroy ( Sender :  TObject );
     procedure  Exit1Click ( Sender :  TObject );
   private
     { Private declarations }
     procedure  LoadPlugins ;               //初始化插件（装入插件，并在菜单提供调用）
     procedure  PluginsClick ( Sender :  TObject );  //插件菜单点击事件
     procedure  FreePlugins ;               //释放插件
   public
     { Public declarations }
   end ;

var
   FrmPluginMain :  TFrmPluginMain ;
   ShowDllForm :  TShowDllForm ;             //声明接口函数类型
   Plugins :  TList ;                        //指针列表,存放每一个DLL加载后的相关信息
   StopSearch :  boolean ;

implementation

{$R *.dfm}
//查找文件，并存于Files中

procedure  SearchFileExt ( const  Dir ,  Ext :  string ;  Files :  TStrings );
var
   found :  TSearchRec ;
   Sub :  string ;
   i :  integer ;
   Dirs :  TStrings ;
   Finished :  integer ;
begin
   StopSearch  :=  false ;
   Dirs  :=  tstringlist . create ;
   finished  :=  findfirst ( dir  +  '*.*' ,  63 ,  Found );
   while  ( finished  =  0 )  and  not  ( StopSearch )  do
   begin
     if  ( Found . Name [ 1 ]  <>  '.' )  then
     begin
       if  ( found . attr  and  faDirectory  =  faDirectory )  then
         dirs . add ( dir  +  found . name )       //加入到目录列表
       else  if  POS ( UpperCase ( Ext ),  UpperCase ( found . name ))  >  0  then
         files . add ( dir  +  found . name );
     end ;
     finished  :=  findnext ( found );
   end ;
   findclose ( found );
   if  not  StopSearch  then
     for  i  :=  0  to  dirs . count  -  1  do
       searchfileext ( Dirs [ i ],  Ext ,  Files );
   Dirs . Free ;
end ;
//装载插件

procedure  TFrmPluginMain . loadPlugins ;
var
   files :  tstrings ;
   i :  integer ;
   MyPlugin :  TMyPlugin ;
   NewMenu :  TMenuItem ;
   GetCaption :  TGetCaption ;               //过程
begin
   files  :=  TStringlist . Create ;
   try
     Plugins  :=  TList . Create ;             //建立指针列表
     //查找当前目录的子目录plugins下的 .dll文件，并存于 files中
     SearchFileExt ( Extractfilepath ( application . ExeName )  +  'Plugins/' ,  '.dll' ,  files );

     //加载找到的DLL
     for  i  :=  0  to  files . Count  -  1  do
     begin
       myPlugin  :=  TMyPlugin . Create ;
       myPlugin . Address  :=  loadlibrary ( pchar ( files [ i ]));
       if  myplugin . Address  =  0  then
         showmessage ( '加载'  +  files [ i ]  +  '失败!' )
       else
       begin
         try
           @ GetCaption  :=  GetProcAddress ( myPlugin . Address ,  'GetCaption' );
           myPlugin . Caption  :=  GetCaption ( application . Handle );
           myPlugin . Call  :=  GetProcAddress ( myPlugin . Address ,  'ShowDllForm' );
           Plugins . Add ( myPlugin );         //加入至指针列表
           //创建菜单，并将菜单标题OnClick事件赋值
           NewMenu  :=  TMenuItem . Create ( self );
           NewMenu . Caption  :=  myplugin . Caption ;
           newmenu . OnClick  :=  PluginsClick ;
           NewMenu . Tag  :=  i ;
           plugins1 . Add ( newMenu );
         except
           showmessage ( '初始化失败!' );
           raise ;
         end ;
       end ;
     end ;
   finally
     FreeAndNil ( files );
   end ;
end ;

//插件菜单项点击事件

procedure  TFrmPluginMain . PluginsClick ( Sender :  TObject );
begin
   //根据菜单项的TAG属性对应函数调用的地址
   @ ShowDllForm  :=  TMyPlugin ( plugins [ tmenuitem ( sender ). Tag ]). Call ;
   // showdllform(application.Handle,'test');
     //执行ShowDllForm函数
   if  not  Showdllform ( application . handle ,  TMyPlugin ( plugins [ TMenuItem ( sender ). Tag ]). Caption )  then
     showmessage ( '打开窗体错误!' );
end ;
//释放插件

procedure  TFrmPluginMain . FreePlugins ;
var
   i :  integer ;
begin
   for  i  :=  0  to  plugins . Count  -  1  do
   begin
     freelibrary ( tmyplugin ( plugins [ i ]). Address );
   end ;
   plugins . free ;
end ;

procedure  TFrmPluginMain . FormCreate ( Sender :  TObject );
begin
   LoadPlugins ;
end ;

procedure  TFrmPluginMain . FormDestroy ( Sender :  TObject );
begin
   FreePlugins ;
end ;

procedure  TFrmPluginMain . Exit1Click ( Sender :  TObject );
begin
   close ;
end ;

end .