BPL插件框架的二种实现方法

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
  aForm: TForm;
begin
  aForm := TFormClass(FindClass(formClass)).Create(Self);
  aForm.Position := poScreenCenter;
  aForm.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.