Conversion WbemScripting_TLB de Delphi vers Lazarus

Énoncé du problème

Dans mes recherches j'ai trouvé du code Delphi faisant (a peu prés) ce que je cherche a faire.

Et effectivement avec Delphi çà marche, mais avec Lazarus, cela ne fonctionne pas !

Le PROBLÈME est ce fichu fichier WbemScripting_TLB.pas qui vient d'une importation d'un fichier TLB C:\WINDOWS\system32\wbem\wbemdisp.TLB pour le fichier originale et C:\Windows\SysWOW64\wbem\wbemdisp.TLB pour le fichier que j'ai moi même régénéré.
Ce fichier n'est pas compatible avec Lazarus.

J'ai donc décidé de créer ce fichier à partir de Lazarus et j'explique ci-dessous comment j'ai fait et les modifications a faire au code source pour que cela fonctionne.

Ci dessous nous allons trouver :

La source originale en Delphi que j'ai trouvé.
Comment importer un TLB avec Lazarus
La source corrigé en Free Pascal

Sources Delphi Originales

Delphi

unit Unit1;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, WbemScripting_TLB, Vcl.StdCtrls;
 
type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    FSink:     TSWbemSink;
    FLocator:  ISWbemLocator;
    FServices: ISWbemServices;
    procedure EventReceived(ASender: TObject; const objWbemObject: ISWbemObject; const objWbemAsyncContext: ISWbemNamedValueSet);
  public
    { Déclarations publiques }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
{ TForm1 }
 
procedure TForm1.Button1Click(Sender: TObject);
const
 WQL = 'SELECT * FROM __InstanceCreationEvent WITHIN 1 WHERE TargetInstance ISA "Win32_Process"';
begin
  FLocator  := CoSWbemLocator.Create;
  //Connect to the WMI service
  FServices := FLocator.ConnectServer('.', 'root\cimv2', '','', '', '', wbemConnectFlagUseMaxWait, nil);
  //create the sink instance
  FSink     := TSWbemSink.Create(self);
  //assign the event handler
  FSink.OnObjectReady := EventReceived;
  //Run the ExecNotificationQueryAsync
  FServices.ExecNotificationQueryAsync(FSink.DefaultInterface,WQL,'WQL', 0, nil, nil);
end;
 
procedure TForm1.EventReceived(ASender: TObject;
  const objWbemObject: ISWbemObject;
  const objWbemAsyncContext: ISWbemNamedValueSet);
var
  PropVal: OLEVariant;
begin
  PropVal := objWbemObject;
  Memo1.Lines.Add(Format('Caption   : %s ',[PropVal.TargetInstance.Caption]));
  Memo1.Lines.Add(Format('ProcessID : %s ',[PropVal.TargetInstance.ProcessID]));
end;
 
end.

Source de ce sode : https://theroadtodelphi.com/2011/04/18/delphi-and-wmi-events/

Importer un fichier TLB avec Lazarus

LazActiveX

Dans un premier temps il faut que le paquet LazActiveX soit installé :

Plus d'infos ici : https://wiki.lazarus.freepascal.org/LazActiveX

Importer le TLB

Cela nous donne accés a un nouveau menu Importer la bibliothèque de types… :

Une fois cliqué sur le menu on se retrouve dans cette fenêtre.

On choisi [ActiveX References]
On cherche [Microsoft WMI Scripting]
On clique sur OK et cela nous génére un fichier WbemScripting_1_2_TLB.pas

Adaptation du code

ATTENTION il y a de grosses differences entre le code généré en Delphi et celui en Lazarus, hormis le nom du fichier…

Exemple avec TSWbemSink

Exemple TSWbemSink est devenu TEvsSWbemSink et ses properties ont changé:

Delphi

  TSWbemSink = class(TOleServer)
  private
    FOnObjectReady: TSWbemSinkOnObjectReady;
    FOnCompleted: TSWbemSinkOnCompleted;
    FOnProgress: TSWbemSinkOnProgress;
    FOnObjectPut: TSWbemSinkOnObjectPut;
    FIntf: ISWbemSink;
    ...
    function GetDefaultInterface: ISWbemSink;
  protected
    procedure InitServerData; override;
    procedure InvokeEvent(DispID: TDispID; var Params: TVariantArray); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure Connect; override;
    procedure ConnectTo(svrIntf: ISWbemSink);
    procedure Disconnect; override;
    procedure Cancel;
    property DefaultInterface: ISWbemSink read GetDefaultInterface;
  published
    property OnObjectReady: TSWbemSinkOnObjectReady read FOnObjectReady write FOnObjectReady;
    property OnCompleted: TSWbemSinkOnCompleted read FOnCompleted write FOnCompleted;
    property OnProgress: TSWbemSinkOnProgress read FOnProgress write FOnProgress;
    property OnObjectPut: TSWbemSinkOnObjectPut read FOnObjectPut write FOnObjectPut;
  end;

Lazarus

  TEvsSWbemSink = Class(TEventSink)
  Private
    FOnOnObjectReady:TISWbemSinkEventsOnObjectReady;
    FOnOnCompleted:TISWbemSinkEventsOnCompleted;
    FOnOnProgress:TISWbemSinkEventsOnProgress;
    FOnOnObjectPut:TISWbemSinkEventsOnObjectPut;
 
    fServer:ISWbemSink;
    procedure EventSinkInvoke(Sender: TObject; DispID: Integer;
          const IID: TGUID; LocaleID: Integer; Flags: Word;
          Params: tagDISPPARAMS; VarResult, ExcepInfo, ArgErr: Pointer);
  Public
    constructor Create(TheOwner: TComponent); override;
    property ComServer:ISWbemSink read fServer;
    property OnOnObjectReady : TISWbemSinkEventsOnObjectReady read FOnOnObjectReady write FOnOnObjectReady;
    property OnOnCompleted : TISWbemSinkEventsOnCompleted read FOnOnCompleted write FOnOnCompleted;
    property OnOnProgress : TISWbemSinkEventsOnProgress read FOnOnProgress write FOnOnProgress;
    property OnOnObjectPut : TISWbemSinkEventsOnObjectPut read FOnOnObjectPut write FOnOnObjectPut;
 
  end;

Code Lazarus

unit Unit1;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  ActiveX,
  StdCtrls,
  SysUtils,
  Forms,
  Controls,
  Dialogs,
  WbemScripting_1_2_TLB;
 
type
 
  { TForm1 }
 
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1:   TMemo;
    procedure Button1Click(Sender: TObject);
  private
    FSink:     TEvsSWbemSink;
    FLocator:  ISWbemLocator;
    FServices: ISWbemServices;
 
    procedure EventReceived(Sender: TObject; objWbemObject: ISWbemObject;
      objWbemAsyncContext: ISWbemNamedValueSet);
  public
 
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.lfm}
 
{ TForm1 }
 
procedure TForm1.Button1Click(Sender: TObject);
const
  WQL = 'SELECT * FROM __InstanceCreationEvent WITHIN 1 WHERE TargetInstance ISA "Win32_Process"';
begin
  FLocator  := CoSWbemLocator.Create;
  //Connect to the WMI service
  FServices := FLocator.ConnectServer('.', 'root\cimv2', '', '', '',
    '', wbemConnectFlagUseMaxWait, nil);
  //create the sink instance
  FSink     := TEvsSWbemSink.Create(self);
  //assign the event handler
  FSink.OnOnObjectReady := @EventReceived;
  //Run the ExecNotificationQueryAsync
  FServices.ExecNotificationQueryAsync(FSink.ComServer, WQL, 'WQL', 0, nil, nil);
end;
 
procedure TForm1.EventReceived(Sender: TObject; objWbemObject: ISWbemObject;
  objWbemAsyncContext: ISWbemNamedValueSet);
var
  PropVal: olevariant;
begin
  PropVal := objWbemObject;
  Memo1.Lines.Add(Format('Caption   : %s ', [PropVal.TargetInstance.Caption]));
  Memo1.Lines.Add(Format('ProcessID : %s ', [PropVal.TargetInstance.ProcessID]));
end;
 
initialization
  CoInitializeEx(nil, COINIT_MULTITHREADED); {Je ne sais pas si c'est utile, mais...}
 
finalization;
  CoUninitialize();
 
end.

Résultat

Sources & Ressources

Vous pourriez laisser un commentaire si vous étiez connecté.

Table des matières