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 a 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 a 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.
					

Type
  TOperationClass = Class of TOperation;

  TOperation = Class(TControl) // ou inférieur
  Public
    Function Execute(Val1, Val2 : Integer) : Integer; Abstract; Virtual;
  End;
				

Type
  TAddition = Class(TOperation)
  Public
    Function Execute(Val1, Val2 : Integer) : Integer; Override;
  End;

Function TAddition.Execute(Val1, Val2 : Integer) : Integer;
Begin
  Result := Val1 + Val2;
End;
				

Type
  TMultiplication = Class(TOperation)
  Public
    Function Execute(Val1, Val2 : Integer) : Integer; Override;
  End;

Function TMultiplication.Execute(Val1, Val2 : Integer) : Integer;
Begin
  Result := Val1 * Val2;
End;
				

unit PluginIntf;

interface

uses
  ExtCtrls;

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

implementation

end.
				

unit TestPlugin;

uses
  ExtCtrls, PluginIntf;

type
  TTestPlugin = class(TInterfacedObject, IPlugin)
  private
    FPanel : TPanel;
  public
    constructor Create;
    destructor Destroy; override;
    function GetComponent : TPanel;
  end;

function CreatePlugin : IPlugin;

exports CreatePlugin;

implementation

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

constructor TTestPlugin.Create;
begin
  inherited;
  FPanel := TPanel.Create(nil);
  with FPanel do
  begin
    Font.Size := 24;
    Font.Color := clBlue;
    Caption := 'Panel créé dans le plug-in';
    Width := 500;
    Height := 300;
  end;
end;

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

function TTestPlugin.GetComponent : TPanel;
begin
  Result := FPanel;
end;

end.
				

unit MainForm;

uses
  Windows, Forms, PluginIntf, ...;

resourcestring
  sUnexistingFile = 'Le fichier ''%s'' n''existe pas';
  sDLLCantBeLoaded = 'La DLL ne peut être chargée';
  sPackageCantBeLoaded = 'Le package ne peut être chargé';
  sUnexistingFunction = 'La fonction %s n''existe pas';

type
  TFormMain = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Déclarations privées }
    PackHandle : HModule;
    Plugin : IPlugin;
  public
    { Déclarations publiques }
  end;

  EPluginError = class(Exception);

implementation

procedure TFormMain.FormCreate(Sender: TObject);
begin
  PackHandle := 0;
  Plugin := nil;
end;

procedure TFormMain.Button1Click(Sender: TObject);
type
  TCreatePluginFunc = function : IPlugin; stdcall;
var CreatePlugin : TCreatePluginFunc;
begin
  if PackHandle <> 0 then exit;
  try
    if not FileExists('TestPlugin.bpl') then
      raise EPluginError.CreateFmt(sUnexistingFile, [FFileName]);
    PackHandle := LoadPackage('TestPlugin.bpl');
    if PackHandle = 0 then
      raise EPluginError.Create(sPackageCantBeLoaded);
    CreatePlugin := GetProcAddress(PackHandle, 'CreatePlugin');
    if CreatePlugin = nil then
      raise EPluginError.CreateFmt(sUnexistingFunction, ['CreatePlugin']);
    Plugin := CreatePlugin;

    with Plugin.Component do
    begin
      ParentWindow := Form.Handle;
      SetParent(Handle, Form.Handle);
      Left := 0;
      Top := 0;
      Visible := True;
    end;
  except
    FormDestroy(nil);
    raise;
  end;
end;

procedure TFormMain.FormDestroy(Sender: TObject);
begin
  if Plugin <> nil then with Plugin.Component do
  begin
    ParentWindow := nil;
    SetParent(Handle, 0);
  end;
  Plugin := nil;
  if PackHandle <> 0 then
    UnloadPackage(FHandle);
  PackHandle := 0;
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}']
    ...
  end;

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

  // Autres interfaces
  ...

implementation

end.
						

unit PluginIntf;

interface

uses
  ...;

type
  // Interface obligatoire
  IPlugin = interface
    ['{F1F7186D-76E3-4DBD-8707-408C792B1C82}']
    ...
  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;

  // Autres interfaces
  ...

implementation

end.
						

unit PluginIntf;

interface

uses
  ...;

type
  // Interface obligatoire
  IPlugin = interface
    ['{F1F7186D-76E3-4DBD-8707-408C792B1C82}']
    ...
  end;

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

  // Autres interfaces
  ...

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.