Différences

Ci-dessous, les différences entre deux révisions de la page.

--- prog:lazarus:cas:wmi:convfromdelphi [03/04/2023 17:18]
thierry [Importer le TLB]
+++ prog:lazarus:cas:wmi:convfromdelphi [03/04/2023 17:47] (Version actuelle)
thierry [Sources & Ressources]
@@ Ligne 1: / Ligne 1: @@
-====== Conversion depuis Delphi ======
+====== 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.
@@ Ligne 12: / Ligne 12: @@
 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 =====
-<code delphi Delphi>
+<code delphi Delphi [enable_line_numbers="true"]>
 unit Unit1;
@@ Ligne 80: / Ligne 82: @@
 {{:prog:lazarus:cas:wmi:activx1.jpg?400|}}
+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...'' :
@@ Ligne 91: / Ligne 95: @@
 {{:prog:lazarus:cas:wmi:actx3.jpg|}}
-==== Adaptation du code ====
+===== 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é:
+<code delphi Delphi [enable_line_numbers="true"]>
+  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;
+</code>
+<code delphi Lazarus [enable_line_numbers="true"]>
+  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>
+==== Code Lazarus ====
+<code delphi [enable_line_numbers="true",highlight_lines_extra="14,25,29,30,53,55,57,60,61"]>
+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.
+</code>
+===== Résultat =====
+{{:prog:lazarus:cas:wmi:extra1.jpg|}}
+====== Sources & Ressources ======
+  * [[https://wiki.lazarus.freepascal.org/LazActiveX]]
+  * [[https://theroadtodelphi.com/2011/04/18/delphi-and-wmi-events/]]