Réaliser un plug-in comportant un composant

Var Module : THandle;
...
Module := LoadPackage('C:\MonPaquet.bpl'); // Chargement
...
UnloadPackage(Module); // Déchargement

Type
  EPluginError = Class(Exception);

...

Var MaClasse : TPersistentClass; // Classe de base
    Instance : TPersistent;      // Instance de l'objet à charger
...
MaClasse := GetClass('TMaClasse'); // Chargement de la classe depuis le package
If MaClasse = nil Then // GetClass renvoie nil en cas d'erreur
  Raise EPluginError.CreateFmt('Classe ''%s'' non trouvée', ['TMaClasse']); // Erreur
// Succes :
Instance := MaClasse.Create; // Création de l'objet

Var Classe : TPersistentClass; // Classe de base
    Instance : TPersistent;    // Instance de l'objet à charger
...
Classe := GetClass('TMaClasse'); // Chargement de la Classe depuis le package
If Classe = nil Then // GetClass renvoie nil en cas d'erreur
  Raise Exception.Create('Classe non trouvée'); // Erreur
// Succes :
Instance := TComponent(Classe).Create(Form1); // Création de l'objet

Var Instance : TPanel;
...
Instance := TPanel(Classe).Create(Form1); // Création de l'objet

// Chargement de Classe
If not Classe.InheritsFrom(TPanel) Then
  Raise Exception.Create('Cast impossible');
// Création de l'instance

Var MonPanel : TPanel;

Procedure CreatePanel;
Var Classe : TPersistentClass;
    Instance : TPanel;
Begin
  Classe := GetClass('TMaClasse');
  If Classe = nil Then
    Raise Exception.Create('Classe non trouvée');
  If not Classe.InheritsFrom(TPanel) Then
    Raise Exception.Create('Cast impossible');
  MonPanel := TPanel(Classe).Create(Form1); // Création de l'objet
  With MonPanel do
  Begin
    Parent := Form1;
    Color := clPurple;
    Align := alClient;
  End;
End;

Unit uMonPanel;

Interface

Uses Sysutils, ExtCtrls, Classes;

Type
  TMonPanel = Class(TPanel)
  Public
    Constructor Create(AOwner : TComponent); Override;
  End;

Implementation

Constructor TMonPanel.Create(Aowner : Tcomponent);
Begin
  Inherited Create(Aowner);
  Self.Color := clPurple;
End;

Initialization
  RegisterClass(TMonPanel);
Finalization
  UnregisterClass(TMonPanel);
End.

unit pkgCommon;

interface

Uses SysUtils, Types, Windows, Dialogs, Classes, Controls, Contnrs;

Type
  TPkgManager = Class(TObject)
  Private
    pInstanceList : Array of TObject;
    pPkgHandle : HModule;
    Procedure AddInstance(AObject : TObject);
    Procedure RemoveInstance(Index : Integer);
    Procedure ClearInstanceList;
    Procedure UpdateInstanceList;
  Public
    Destructor Destroy; Override;
    Procedure LoadPkg(APackage : String);
    Procedure UnLoadPkg;
    Function CreateInstanceOf(AClass : String) : TPersistent; Overload;
    Function CreateInstanceOf(AClass : String; AOwner : TComponent) : TControl; Overload;
  end;

implementation

ResourceString
  PKGALREADYCHARGED_ERROR_MSG = 'Un paquet est déjà chargé';
  LOADPKG_ERROR_MSG = 'Impossible de charger le paquet ''%s''';
  GETCLASS_ERROR_MSG = 'Impossible de charger la classe ''%s''';

Type
  TPkgGetClasses = Function : TStringDynArray;

Var
  GetClasses : TPkgGetClasses;

//------------------------------------------------------------------------------

Destructor TPkgManager.Destroy;
Begin
  Self.UnLoadPkg;     // Appel direct, car UnLoadPkg est une méthode "Safe"
  Inherited Destroy;
end;

//------------------------------------------------------------------------------

Procedure TPkgManager.LoadPkg(APackage : String);
Begin
  If Self.pPkgHandle <> 0 then
    Raise Exception.Create(PKGALREADYCHARGED_ERROR_MSG);
  Self.pPkgHandle := LoadPackage(APAckage);
  If Self.pPkgHandle = 0 then
    Raise Exception.CreateFmt(LOADPKG_ERROR_MSG, [APackage]);
End;

//------------------------------------------------------------------------------

Procedure TPkgManager.UnLoadPkg;
Begin
  If Self.pPkgHandle <> 0 Then
  Begin
    Self.ClearInstanceList;
    UnLoadPackage(Self.pPkgHandle);
  end;
End;

//------------------------------------------------------------------------------

Function TPkgManager.CreateInstanceOf(AClass : String) : TPersistent;
Var Classe : TPersistentClass;
    Instance : TPersistent;
Begin
  Classe := GetClass(AClass);
  If Classe = Nil Then
    Raise Exception.CreateFmt(GETCLASS_ERROR_MSG, [AClass]);
  Instance := Classe.Create;
  Self.AddInstance(Instance);
  Result := Instance;
End;

//------------------------------------------------------------------------------

Function TPkgManager.CreateInstanceOf(AClass : String; AOwner : TComponent) : TControl;
Var Classe : TPersistentClass;
    Instance : TControl;
Begin
  Classe := GetClass(AClass);
  If Classe = Nil Then
    Raise Exception.CreateFmt(GETCLASS_ERROR_MSG, [AClass]);
  Instance := TControlClass(Classe).Create(AOwner);
  Self.AddInstance(Instance);
  Result := Instance;
End;

//------------------------------------------------------------------------------

Procedure TPkgManager.AddInstance(AObject : TObject);
Var Size : Integer;
Begin
  Size := Length(Self.pInstanceList);
  SetLength(Self.pInstanceList, Size+1);
  Self.pInstanceList[Size] := AObject;
End;

//------------------------------------------------------------------------------

Procedure TPkgMAnager.ClearInstanceList;
Var i : Integer;
Begin
  For i := 0 to Length(Self.pInstanceList)-1 do
    If Assigned(Self.pInstanceList[i]) Then
      FreeAndNil(Self.pInstanceList[i]);
End;

//------------------------------------------------------------------------------

Procedure TPkgManager.RemoveInstance(Index : Integer);
Var Size : Integer;
Begin
  Size := Length(Self.pInstanceList);
  If Index = Size-1 Then
    SetLength(Self.pInstanceList, Size-1)
  Else
  Begin
    Self.pInstanceList[index] := Self.pInstanceList[Size-1];
    SetLength(Self.pInstanceList, Size-1);
  End;
End;

//------------------------------------------------------------------------------

Procedure TPkgManager.UpdateInstanceList;
Var i : Integer;
Begin
  i := 0;
  While i < Length(Self.pInstanceList) do
  Begin
    If Not Assigned(Self.pInstanceList[i]) then
      Self.RemoveInstance(i);
    Inc(i);
  End;
End;

//------------------------------------------------------------------------------

End.

unit PluginIntf;

interface

uses
  ...;

type
  IPlugin = interface
    ['{F1F7186D-76E3-4DBD-8707-408C792B1C82}']
    function GetComponent : TAncetre;
    property Component : TAncetre read GetComponent;
  end;

implementation

end.

unit PluginIntf;

interface

uses
  ...;

const
  // Types de commandes pour IPluginCommands
  ComType_BigMenu = 'BigMenu';
  ComType_MenuSeparator = 'MenuSeparator';
  ComType_Menu = 'Menu';

type
  // Type de call-back pour l'ajout de commandes
  TEnumCommandsProc = procedure(ComType, Caption, Hint : string;
                                Shortcut : TShortCut; Bitmap : TBitmap;
                                OnExecute : TNotifyEvent) of object;

  // Interface obligatoire
  IPlugin = interface
    ['{F1F7186D-76E3-4DBD-8707-408C792B1C82}']
    function GetComponent : TAncetre;
    property Component : TAncetre read GetComponent;
  end;

  // Interface pour les commandes
  IPluginCommands = interface
    ['{5E46D466-0D18-4733-84F8-D7F60EF00C71}']
    procedure EnumCommands(EnumCommandsProc : TEnumCommandsProc);
  end;

  // Interface pour le redimensionnement
  IPluginSizeable = interface
    ['{CD829089-E50B-41E4-94DD-41108282A762}']
    function GetMinWidth : integer;
    function GetMaxWidth : integer;
    function GetMinHeight : integer;
    function GetMaxHeight : integer;
    function GetCanMaximize : boolean;

    property MinWidth : integer read GetMinWidth;
    property MaxWidth : integer read GetMaxWidth;
    property MinHeight : integer read GetMinHeight;
    property MaxHeight : integer read GetMaxHeight;
    property CanMaximize : boolean read GetCanMaximize;
  end;

  // Interface pour les événements
  IPluginEvents = interface
    ['{262BDFEE-8DC4-47F7-8A64-2FB728C32FCE}']
    procedure QueryUnload(var CanUnload : boolean);
  end;

implementation

end.

unit TestPlugin;

interface

uses
  PluginIntf, ...;

type
  // Composant qui sera effectivement inséré dans la fiche
  TMonComposant = class(TAncetre);
    ...
  end;

  // Classe implémentant les interfaces
  TTestPlugin = class(TInterfacedObject, IPlugin, IPluginCommands, IPluginSizeable, IPluginEvents)
  private
    FComponent : TMonComposant;

    procedure TestExecute(Sender : TObject);
  public
    constructor Create;
    destructor Destroy; override;

    // Implémentation de IPlugin
    function GetComponent : TAncetre;

    // Implémentation de IPluginCommands
    procedure EnumCommands(EnumCommandsProc : TEnumCommandsProc);

    // Implémentation de IPluginSizeable
    function GetMinWidth : integer;
    function GetMaxWidth : integer;
    function GetMinHeight : integer;
    function GetMaxHeight : integer;
    function GetCanMaximize : boolean;

    // Implémentation de IPluginEvents
    procedure QueryUnload(var CanUnload : boolean);
  end;

function CreatePlugin : IPlugin; stdcall;

exports CreatePlugin;

implementation

function CreatePlugin : IPlugin;
begin
  Result := TTestPlugin.Create;
end;

constructor TTestPlugin.Create;
begin
  inherited;
  FComponent := TMonComposant.Create(nil);
end;

destructor TTestPlugin.Destroy;
begin
  FComponent.Free;
  inherited;
end;

procedure TTestPlugin.TestExecute(Sender : TObject);
begin
  ShowMessage('Test d''événement');
end;

function TTestPlugin.GetComponent : TAncetre;
begin
  Result := FComponent;
end;

procedure TTestPlugin.EnumCommands(EnumCommandsProc : TEnumCommandsProc);
begin
  EnumCommandsProc(ComType_BigMenu, 'Test', 'Test de menu principal', 0, nil, nil);
  EnumCommandsProc(ComType_Menu, 'Test', 'Test de menu', 0, nil, TestExecute);
end;

function TTestPlugin.GetMinWidth : integer;
begin
  Result := 100;
end;

function TTestPlugin.GetMaxWidth : integer;
begin
  Result := 0;
end;

function TTestPlugin.GetMinHeight : integer;
begin
  Result := 200;
end;

function TTestPlugin.GetMaxHeight : integer;
begin
  Result := 0;
end;

function TTestPlugin.GetCanMaximize : boolean;
begin
  Result := True;
end;

procedure TTestPlugin.QueryUnload(var CanUnload : boolean);
begin
  CanUnload := MessageBox('Voulez-vous vraiment décharger ce plug-in ?',
                          mtConfirmation, [mbYes, mbNo]) = mrYes;
end;

end.

unit MainForm;

interface

uses
  PluginClass, ...;

type
  TFormMain = class(TForm)
    ImageList: TImageList;
    ActionList: TActionList;
    ActionCharger: TAction;
    ActionDecharger: TAction;
    BigMenu: TMainMenu;
    BigMenuFichier: TMenuItem;
    MenuCharger: TMenuItem;
    MenuDecharger: TMenuItem;
    ToolBar: TToolBar;
    ToolButtonCharger: TToolButton;
    ToolButtonDecharger: TToolButton;
    StatusBar: TStatusBar;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ActionChargerExecute(Sender: TObject);
    procedure ActionDechargerExecute(Sender: TObject);
    procedure ResizePlugin(Sender: TObject);
  private
    { Déclarations privées }
    Plugin : TPlugin;
  public
    { Déclarations publiques }
  end;

var
  FormMain: TFormMain;

implementation

procedure TFormMain.FormCreate(Sender: TObject);
begin
  Plugin := TPlugin.Create('TestPlugin.bpl');
end;

procedure TFormMain.FormDestroy(Sender: TObject);
begin
  Plugin.Free;
end;

procedure TFormMain.ActionChargerExecute(Sender: TObject);
begin
  Plugin.Load(Self, BigMenu.Items, ImageList, ToolBar.Height);
  ClientWidth := Plugin.Width;
  ClientHeight := Plugin.Height+ToolBar.Height+StatusBar.Height;
  if Plugin.CanResize then
  begin
    BorderStyle := bsSizeable;
    with Constraints do
    begin
      MinWidth := Plugin.MinWidth;
      MaxWidth := Plugin.MaxWidth;
      MinHeight := Plugin.MinHeight+ToolBar.Height+StatusBar.Height;
      MaxHeight := Plugin.MaxHeight+ToolBar.Height+StatusBar.Height;
    end;
    if Plugin.CanMaximize then
      BorderIcons := [biSystemMenu, biMinimize, biMaximize];
    OnResize := ResizePlugin;
  end;
end;

procedure TFormMain.ActionDechargerExecute(Sender: TObject);
begin
  OnResize := nil;
  Plugin.Unload;
  BorderIcons := [biSystemMenu, biMinimize];
  width Constraints do
  begin
    MinWidth := 0;
    MaxWidth := 0;
    MinHeight := 0;
    MaxHeight := 0;
  end;
  BorderStyle := bsSingle;
  ClientWidth := 300;
  ClientHeight := 200;
end;

procedure TFormMain.ResizePlugin(Sender: TObject);
begin
  Plugin.Width := ClientWidth;
  Plugin.Height := ClientHeight-ToolBar.Height-StatusBar.Height;
end;

end.