BPL插件框架的二种实现

1）非RTTI方式适用于所有的DELPHI版本

unit untMain;

interface

uses
Windows, Messages, SysUtils,
Classes, Graphics,
Controls, Forms, Dialogs,
ExtCtrls, Buttons;

type
TFrmMain = class(TForm)
Panel1: TPanel;
SpeedButton1: TSpeedButton;
procedure btnClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
procedure LoadPlugin(const formClass: string);
public
{ Public declarations }
end;

var
FrmMain: TFrmMain;

implementation

{$R *.dfm}

procedure TFrmMain.btnClick(Sender: TObject);
var
h: Integer;
formClass, bplFile: string;
begin
if SameText(TSpeedButton(Sender).Caption, '系统一') then
begin
bplFile := 'bplTest1.bpl';
formClass := 'TfrmTest1';
end;

if TSpeedButton(Sender).Tag = 0 then
begin
if FileExists(bplFile) then
begin
h := LoadPackage(bplFile);
if h = 0 then
ShowMessage(bplFile + ' 包加载失败')
else
begin
TSpeedButton(Sender).Tag := h;
end;
end
else
ShowMessage(bplFile + ' 没有找到');
end;

LoadPlugin(formClass);
end;

procedure TFrmMain.FormDestroy(Sender: TObject);
var
i: integer;
begin
for i := 0 to Panel1.ComponentCount - 1 do
begin
if TSpeedButton(Panel1.Components[i]).Tag <> 0 then
UnloadPackage(TSpeedButton(Panel1.Components[i]).Tag);
end;
end;

procedure TFrmMain.LoadPlugin(const formClass: string);
var
form: TForm;
begin
form := TFormClass(FindClass(formClass)).Create(Self);
form.Position := poScreenCenter;
form.Show;
end;

end.

2）RTTI方式，适用于2009以上版本

unit untMain;

interface

uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Generics.Collections,
System.Rtti, Vcl.ExtCtrls, Vcl.Buttons;

type
TFrmMain = class(TForm)
Panel1: TPanel;
SpeedButton1: TSpeedButton;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btnClick(Sender: TObject);
private
{ Private declarations }
bplList: TDictionary<string, Integer>;
procedure LoadPlugin(const bplFile, unitClass: string);
public
{ Public declarations }
end;

var
FrmMain: TFrmMain;

implementation

{$R *.dfm}

procedure TFrmMain.btnClick(Sender: TObject);
var
h: Integer;
bplFile: string;
unitClass: string;
begin
if SameText(TSpeedButton(Sender).Caption, '系统一') then
begin
bplFile := 'bplTest1.bpl';
unitClass := 'untTest1.TfrmTest1';
end;

if TSpeedButton(Sender).Tag = 0 then
begin
if FileExists(bplFile) then
begin
h := LoadPackage(bplFile);
if h = 0 then
ShowMessage(bplFile + ' 包加载失败')
else
begin
bplList.Add(bplFile, h);
TSpeedButton(Sender).Tag := h;
end;
end;
end;

LoadPlugin(bplFile, unitClass);
end;

procedure TFrmMain.FormCreate(Sender: TObject);
begin
bplList := TDictionary<string, Integer>.Create;
end;

procedure TFrmMain.FormDestroy(Sender: TObject);
var
i: Integer;
begin
if Assigned(bplList) then
begin
for i in bplList.Values do
UnloadPackage(i);
FreeAndNil(bplList);
end;
end;

procedure TFrmMain.LoadPlugin(const bplFile, unitClass: string);
var
LContext: TRttiContext;
LPackage: TRttiPackage;
LClass: TRttiInstanceType;
aForm: TForm;
begin
if (bplFile = '') or (unitClass = '') then
Exit;

LContext := TRttiContext.Create;
try
try
for LPackage in LContext.GetPackages() do
begin
if SameText(ExtractFileName(LPackage.Name), bplFile) then
begin
LClass := LPackage.FindType(unitClass) as TRttiInstanceType;
aForm := LClass.MetaclassType.Create as TForm;
aForm.Create(nil);
aForm.WindowState := wsNormal;
aForm.Position := poScreenCenter;
aForm.Show;
end;
end;
except
ShowMessage('单元名和类名是大小写敏感的');
end;
finally
LContext.Free;
end;
end;

end.