library Project1;

{ Remarque importante concernant la gestion de mémoire de DLL : ShareMem doit
  être la première unité de la clause USES de votre bibliothèque ET de votre projet
  (sélectionnez Projet-Voir source) si votre DLL exporte des procédures ou des
  fonctions qui passent des chaînes en tant que paramètres ou résultats de fonction.
  Cela s'applique à toutes les chaînes passées de et vers votre DLL --même celles
  qui sont imbriquées dans des enregistrements et classes. ShareMem est l'unité
  d'interface pour le gestionnaire de mémoire partagée BORLNDMM.DLL, qui doit
  être déployé avec vos DLL. Pour éviter d'utiliser BORLNDMM.DLL, passez les
  informations de chaînes avec des paramètres PChar ou ShortString. }

uses
  SysUtils,
  Classes;

{$R *.res}

begin
end.

library DLL1;

{ Remarque importante concernant la gestion de mémoire de DLL .... }

uses
  SysUtils,
  Classes;

{$R *.res}

{$R fichier_ressources.res}

begin
end.

library DLL1;

{ Remarque importante concernant la gestion de mémoire de DLL .... }

uses
  SysUtils,
  Classes;

{$R *.res}


function Somme(A, B: Integer): Integer; stdcall;
begin
  Result := A + B;
end;

begin
end.

library DLL1;

{ Remarque importante concernant la gestion de mémoire de DLL .... }

uses
  SysUtils,
  Classes;

{$R *.res}


function Somme(A, B: Integer): Integer; stdcall;
begin
  Result := A + B;
end;

exports
  Somme; //Sans précision, le nom d'exportation sera "Somme" et l'index 1

begin
end.

....
const
  NomDLL = 'DLL1.dll';

  function Somme(A, B: Integer): Integer; stdcall; external NomDLL; 
  
implementation
....

 //Importation en spécifiant le nom de la fonction
function Somme(A, B: Integer): Integer; stdcall; external NomDLL name 'Somme'; 

//Importation en spécifiant son index
function Somme(A, B: Integer): Integer; stdcall; external NomDLL index 0;

procedure TForm1.btnSommeClick(Sender: TObject);
begin
  ShowMessageFmt('%d + %d = %d', [A.Value, B.Value, Somme(.Value, B.Value)]);
end;

...

implementation

...

function LierFonction(DLL: String; var HandleDLL: THandle; NomFct: String; IndexFct: Integer = -1): Pointer;
begin
  //Valeurs de retour par défaut
  Result := nil;
  HandleDLL := 0;

  //Chargement de la DLL. On récupère son handle
  HandleDLL := LoadLibrary(pAnsiChar(DLL));

  //Si le chargement a échoué, on sort
  If HandleDLL = 0 then
    Exit;

  //On récupère l'adresse de la fonction voulue, que l'on renvoie
  If IndexFct < 0 then //Si l'index est négatif on utilise le nom sous forme de chaîne
    Result := GetProcAddress(HandleDLL, pAnsiChar(NomFct))
  else                  
    //Sinon, on utilise l'index comme identifiant
    Result := GetProcAddress(HandleDLL, pAnsiChar(IndexFct));
end;

procedure TForm1.btnSommeClick(Sender: TObject);
var HandleDLL: THandle; //Pour stocker le handle de la DLL chargée
    Somme    : function(A, B: LongInt): LongInt; stdcall; //Notre fonction, sous forme de variable
begin
  //On récupère le pointeur sur notre fonction nommée 'Somme' au sein de DLL1.dll
  Somme := LierFonction('DLL1.dll', HandleDLL, 'Somme');

  //Si Somme a bien reçu un pointeur valide sur une fonction
  If assigned(Somme) then
  try
    //L'appel de la fonction se passe comme avec une fonction ordinaire
    ShowMessageFmt('%d + %d = %d', [A.Value, B.Value, Somme(.Value, B.Value)]);
  finally
//Ne pas oublier de libérer la DLL lorsqu'elle n'est plus nécessaire
    FreeLibrary(HandleDLL);
  end
  else
    //Sinon, on affiche un message d'erreur : appeler Somme provoquerait une violation d'accès
    ShowMessage('Erreur de chargement de la fonction "Somme"');
end;

function xorChar(Caractere: Char; Valeur: Integer): Char;
begin
  Result := Chr(Ord(Caractere) xor Valeur)
end;

function cesChar(Caractere: Char; Decalage: Integer): Char;
begin
  Result := Chr(Ord(Caractere) + Decalage);
end;

function Sauver(Fichier, Contenu: pAnsiChar; Methode: TCryptMethod; Valeur: Integer): Boolean; stdcall;
var
  Stream: TFileStream;
  p     : pChar;
  Data  : Char;
begin

  Result := True;

  //On copie le pointeur du contenu à enregistrer
  p := Contenu;

  //Création du stream de fichier
  Stream := TFileStream.Create(Fichier, fmCreate);
  try
    try
      //Tant qu'on n'a pas atteint la fin du texte à enregistrer
      while p^ <> #0 do
      begin

        //Cryptage du caractère en fonction de la méthode choisie
        case Methode of
          cmXOR  : Data := xorChar(p^, Valeur);
          cmCesar: Data := cesChar(p^, Valeur);
        end;

        //Puis écriture dans le fichier et on avance d'un caractère
        Stream.Write(Data, 1);
        inc(p);
      end;
      //Ecriture du caractère de fin de chaîne
      Data := #0;
      Stream.Write(Data, 1);
    except
      //S'il y a eu une erreur on renvoie False
      on Exception do
        Result := False;
    end;
  finally
    Stream.Free;
  end;
end;

type
  TCryptMethod = (cmXOR = 0, cmCesar = 1);

function Charger(Fichier, Destination: pAnsiChar; Methode: TCryptMethod; Valeur: Integer): Integer; stdcall;
var
  Stream: TFileStream;
  p     : pChar;
begin

  Result := 0;

  //Ouverture du fichier à charger
  Stream := TFileStream.Create(Fichier, fmOpenRead);

  If Destination = nil then
  begin
    //Si Destination = nil c'est la taille du buffer que l'on renvoie
    Result := Stream.Size;
    Stream.Free;
    Exit;
  end
  else
  try
    //Sinon on copie le fichier tel quel dans le buffer de destination
    Stream.Seek(0, soFromBeginning);
    Stream.Read(Destination^, Stream.Size);

    //Puis tant qu'on n'est pas à la fin du texte, on remplace chaque caractère
    //par sa valeur décryptée 
    p := Destination;
    while p^ <> #0 do
    begin

      case Methode of
        cmXOR  : p^ := xorChar(p^, Valeur);
        cmCesar: p^ := cesChar(p^, -Valeur);
      end;

      inc(p);
    end;

  finally
    Stream.Free;
  end;

end;

exports
  Sauver  index 0 name 'Sauver' ,
  Charger index 1 name 'Charger';

interface

...

type
  TCryptMethod = (cmXOR = 0, cmCesar = 1);

  //Déclarations statiques des fonctions de chargement/enregistrement du texte
  function Sauver (Fichier, Contenu    : pAnsiChar; Methode: TCryptMethod;
                   Valeur: Integer): Boolean; stdcall; external 'OpFichiers.dll';
  function Charger(Fichier, Destination: pAnsiChar; Methode: TCryptMethod;
                   Valeur: Integer): Integer; stdcall; external 'OpFichiers.dll';
                   
const
  CRYPT_VAL = 15;
...

procedure TForm1.Button2Click(Sender: TObject);
var
  Fichier: String;
begin

  //Choix de la destination du fichier à créer
  If not PromptForFileName(Fichier, 'Fichier texte (*.txt)|*.txt', '', '', '', True) then
    Exit;

  //Puis on appelle la fonction en prévenant d'une éventuelle erreur de sauvegarde
  If not Sauver(pAnsiChar(Fichier), memTexte.Lines.GetText, TCryptMethod(cbxMethode.ItemIndex), CRYPT_VAL) then
    ShowMessage('Erreur de sauvegarde !');

end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Fichier: String;
  Contenu: pAnsiChar;
  Taille : Integer;
begin

  //Demande du fichier à charger
  If not PromptForFileName(Fichier, 'Fichier texte (*.txt)|*.txt') then
    Exit;

  //On récupère la taille du buffer à créer par un premier appel avec Destination = nil
  Taille := Charger(pAnsiChar(Fichier), nil, TCryptMethod(cbxMethode.ItemIndex), CRYPT_VAL);

  //Allocation du buffer qui recevra le texte à charger
  GetMem(Contenu, Taille);

  //Ce buffer créé, on le passe à la fonction Charger pour y récupérer le texte de notre fichier
  Charger(pAnsiChar(Fichier), Contenu, TCryptMethod(cbxMethode.ItemIndex), CRYPT_VAL);
  //Ajout du texte au Memo
  memTexte.Lines.SetText(Contenu);

  //Libération du buffer 
  FreeMem(Contenu);

end;

function GetName: ShortString; stdcall;
begin
  Result := 'Exemple - DLL n°1';
end;

Type
  TItem = record
    Nom     : ShortString;
    Fonction: ShortString;
   end;
   
  TItemsList = Array of TItem;

const
  ItemsCaptions: Array[0..2]Of ShortString = ('Item1', 'Item2', 'Item3');

function GetItemsList: TItemsList; stdcall;
var
  i: Integer;
begin
  //On ajuste la taille du tableau
  SetLength(Result, Length(ItemsCaptions));

  For i := Low(ItemsCaptions) to High(ItemsCaptions) do
  begin
    //Nom de l'item
    Result[i].Nom      := ItemsCaptions[i];
    //Identifiant de la procédure associée à l'item
    Result[i].Fonction := 'Exec' + ItemsCaptions[i];
  end;
end;

procedure ExecItem1(Sender: TObject); stdcall;
begin
  Windows.MessageBox(0, 'Vous avez cliqué sur le premier item !!', 'ExecItem1', MB_OK);
end;

procedure ExecItem2(Sender: TObject); stdcall;
begin
  Windows.MessageBox(0, 'Vous avez cliqué sur le second item !!', 'ExecItem2', MB_OK);
end;

procedure ExecItem3(Sender: TObject); stdcall;
begin
  Windows.MessageBox(0, 'Vous avez cliqué sur le troisième item !!', 'ExecItem3', MB_OK);
end;

exports
  GetName      index 0 name 'GetName',
  GetItemsList index 1 name 'GetItemsList',
  ExecItem1    index 2 name 'ExecItem1',
  ExecItem2    index 3 name 'ExecItem2',
  ExecItem3    index 4 name 'ExecItem3';

var
  Form1: TForm1;
  Plugins: Array Of THandle;

procedure TForm1.FormCreate(Sender: TObject);
var
  SR: TSearchRec;
  
  {* AjoutMenu sera insérée ici *}
  
begin
  //Recherche des fichiers DLL présents dans le répertoire "/plugins"
  If FindFirst(ExtractFilePath(ParamStr(0)) + '\plugins\*.dll', faAnyFile, SR) = 0 then
  begin
    //Ajout de la première DLL
    AjoutMenu(0);

    //Traitement des autres DLL éventuellement présentes
    while FindNext(SR) = 0 do
    begin
      //Une nouvelle DLL = un élément de plus
      AjoutMenu(High(Plugins) + 1);
    end;
    
    //Libération des ressources allouées pour la recherche 
    FindClose(SR);
  end;
end;

  procedure AjoutMenu(Index: Integer);
  var
    i: Integer;
    Item, SousItem: TMenuItem;
    ItemsList: TItemsList;
    //Deux fonctions à récupérer dans la DLL :
    PluginName  : function: ShortString; stdcall;
    GetItemsList: function: TItemsList;  stdcall;
  begin
    //Agrandissement du tableau de DLL
    SetLength(Plugins, Index + 1);
    //On n'a pas encore le handle de notre DLL chargée
    Plugins[Index] := 0;
    //Ce qui va être fait en liant la fonction GetName
    PluginName := LierFonction(ExtractFilePath(ParamStr(0)) + '\plugins\' + SR.Name, Plugins[Index], 'GetName');

    //Si la fonction n'est pas assignée, ce n'est pas un plugin
    If not Assigned(PluginName) then
    begin
      //Libération de la DLL si besoin
      If Plugins[Index] <> 0 then
        FreeLibrary(Plugins[Index]);
      //On remet le tableau de DLL à la bonne taille
      SetLength(Plugins, Index);
      //Information dans la ListBox
      lstDLL.Items.Add('La DLL "' + SR.Name + '" n''est pas un plugin valide.')
    end
    else
    begin
      //Création du nouveau menu, avec le nom du plugin
      Item := TMenuItem.Create(Menu);
      Item.Caption := PluginName;
      Menu.Items.Add(Item);

      //Ajout à la ListBox du nouveau plugin trouvé
      lstDLL.Items.Add('Nouveau plugin "' + PluginName + '" dans la DLL "' + SR.Name +'"');

      //Liaison de la fonction GetItemsList
      GetItemsList := LierFonction('', Plugins[Index], 'GetItemsList');

      //S'il y a eu un problème de chargement il ne faut pas continuer
      If not Assigned(GetItemsList) then
      begin
        lstDLL.Items.Add('Fonction "GetItemsList" manquante dans la DLL "' + SR.Name + '"');
        Exit;
      end;

      //On récupère maintenant les Items qui formeront le menu
      SetLength(ItemsList, 0);
      ItemsList := GetItemsList;

      //Et on les ajoute un à un au menu créé pour la DLL
      for i := Low(ItemsList) to High(ItemsList) do
      begin
        SousItem := TMenuItem.Create(Menu);
        SousItem.Caption := ItemsList[i].Nom;
        //On stocke dans Hint le nom de la fonction à appeler pour l'exécution de l'item
        SousItem.Hint    := ItemsList[i].Fonction;
        //Et dans Tag l'index de la DLL contenant la fonction de notre item
        SousItem.Tag     := Index;
        //La procédure qui gère l'événement OnClick
        SousItem.OnClick := ExecItem;
        //Ajout du sous-item au menu
        Item.Add(SousItem);
        //Information de cet ajout
        lstDLL.Items.Add('---> Ajout de l''item "' + SousItem.Caption + '"');
      end;
    end;
  end;

procedure TForm1.ExecItem(Sender: TObject);
var
  Item     : TMenuItem;
  Execution: procedure(Sender: TObject); stdcall;
begin
  //Si l'appelant n'est pas un TMenuItem on sort
  If not (Sender is TMenuItem) then Exit;

  //On récupère la fonction associée à l'item dans la DLL
  Item      := TMenuItem(Sender);
  Execution := LierFonction('', Plugins[Item.Tag], Item.Hint);

  //Et on appelle cette fonction
  Execution(Sender);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var i: Integer;
begin
  for i := Low(Plugins) to High(Plugins) do
    FreeLibrary(Plugins[i]);
end;