The Road to Delphi

Delphi – Free Pascal – Oxygene


45 Comments

Hosting Preview Handlers in Delphi VCL Applications

In this post i will show you, how you can host an existing Preview Handler in your Delphi VCL App. Preview handlers are a lightweight and read-only preview of a file contents that are bound to a the preview pane window of the explorer or a another window, all this is done without launching the file’s associated application.

The Preview Handlers was introduced in Windows Vista and are used mainly by the Windows Explorer and other applications like MS Outlook. Hosting an existing preview handler in your application will able to display a preview of most major office document formats, media files, CAD files and so on.

To host a preview handler, first we need find the CLSID of the preview associated to a file extension, this info is located in the windows registry, the default value of the {8895b1c6-b41f-4c1c-a562-0d564250836f} subkey is the class identifier (CLSID) of the handler. An example of the extfile ProgID subkey is shown here, associating a handler of CLSID {11111111-2222-3333-4444-555555555555}.

HKEY_CLASSES_ROOT
   extfile
      shellex
         {8895b1c6-b41f-4c1c-a562-0d564250836f}
            (Default) = [REG_SZ] {11111111-2222-3333-4444-555555555555}

So you can wrote a method like this to get the CLSID of the preview handler associated to a file.

function GetPreviewHandlerCLSID(const AFileName: string): string;
var
  LRegistry: TRegistry;
  LKey: String;
begin
  LRegistry := TRegistry.Create();
  try
    LRegistry.RootKey := HKEY_CLASSES_ROOT;
    LKey := ExtractFileExt(AFileName) + '\shellex\{8895b1c6-b41f-4c1c-a562-0d564250836f}';
    if LRegistry.KeyExists(LKey) then
    begin
      LRegistry.OpenKeyReadOnly(LKey);
      Result:=LRegistry.ReadString('');
      LRegistry.CloseKey;
    end
    else
      Result := '';
  finally
    LRegistry.Free;
  end;
end;

Now with the proper CLSID we can create an instance the IPreviewHandler interface

var
    FPreviewHandler : IPreviewHandler;
begin
  ...
  ...
  FPreviewHandler := CreateComObject(LPreviewGUID) As IPreviewHandler;

The next step is determine how the preview handler was implemented using a IInitializeWithStream.Initialize, IInitializeWithFile, or IInitializeWithItem interface and then call the proper Initialize method.

  if FPreviewHandler.QueryInterface(IInitializeWithFile, LInitializeWithFile) = S_OK then
    LInitializeWithFile.Initialize(StringToOleStr(FFileName), STGM_READ)
  else
  if FPreviewHandler.QueryInterface(IInitializeWithStream, LInitializeWithStream) = S_OK then
  begin
    LFileStream := TFileStream.Create(FFileName, fmOpenRead);
    LIStream := TStreamAdapter.Create(LFileStream, soOwned) as IStream;
    LInitializeWithStream.Initialize(LIStream, STGM_READ);
  end
  else
  if FPreviewHandler.QueryInterface(IInitializeWithItem, LInitializeWithItem) = S_OK then
  begin
    SHCreateItemFromParsingName(PChar(FileName), nil, StringToGUID(GUID_ISHELLITEM), LShellItem);
    LInitializeWithItem.Initialize(LShellItem, 0);
  end;

Finally we need to call the SetWindow (passing the proper host window handle and TRect) and the DoPreview methods of the IPreviewHandler interface.

I encapsulate all the above code in a component called THostPreviewHandler and this is the source code.

{**************************************************************************************************}
{                                                                                                  }
{ Unit uHostPreview                                                                                }
{ component for host preview handlers                                                              }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is uHostPreview.pas.                                                           }
{                                                                                                  }
{ The Initial Developer of the Original Code is Rodrigo Ruz V.   Copyright (C) 2013.               }
{ All Rights Reserved.                                                                             }
{                                                                                                  }
{**************************************************************************************************}

unit uHostPreview;

interface

uses
  ShlObj,
  Classes,
  Messages,
  Controls;

type
  THostPreviewHandler = class(TCustomControl)
  private
    FFileStream     : TFileStream;
    FPreviewGUIDStr : string;
    FFileName: string;
    FLoaded :Boolean;
    FPreviewHandler : IPreviewHandler;
    procedure SetFileName(const Value: string);
    procedure LoadPreviewHandler;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    procedure Paint; override;
  public
    property FileName: string read FFileName write SetFileName;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;


implementation

uses
 SysUtils,
 Windows,
 Graphics,
 ComObj,
 ActiveX,
 Registry,
 PropSys;

constructor THostPreviewHandler.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPreviewHandler:=nil;
  FPreviewGUIDStr:='';
  FFileStream:=nil;
end;

procedure THostPreviewHandler.Paint;
const
  Msg = 'No preview available.';
var
  lpRect: TRect;
begin
 if (FPreviewGUIDStr<>'') and (FPreviewHandler<>nil) and not FLoaded then
 begin
  FLoaded:=True;
  FPreviewHandler.DoPreview;
  FPreviewHandler.SetFocus;
 end
 else
 if FPreviewGUIDStr='' then
 begin
   lpRect:=Rect(0, 0, Self.Width, Self.Height);
   Canvas.Brush.Style :=bsClear;
   Canvas.Font.Color  :=clWindowText;
   DrawText(Canvas.Handle, PChar(Msg) ,Length(Msg), lpRect, DT_VCENTER or DT_CENTER or DT_SINGLELINE);
 end;
end;

destructor THostPreviewHandler.Destroy;
begin
  if (FPreviewHandler<>nil) then
    FPreviewHandler.Unload;

  if FFileStream<>nil then
    FFileStream.Free;

  inherited;
end;

function GetPreviewHandlerCLSID(const AFileName: string): string;
var
  LRegistry: TRegistry;
  LKey: String;
begin
  LRegistry := TRegistry.Create();
  try
    LRegistry.RootKey := HKEY_CLASSES_ROOT;
    LKey := ExtractFileExt(AFileName) + '\shellex\{8895b1c6-b41f-4c1c-a562-0d564250836f}';
    if LRegistry.KeyExists(LKey) then
    begin
      LRegistry.OpenKeyReadOnly(LKey);
      Result:=LRegistry.ReadString('');
      LRegistry.CloseKey;
    end
    else
      Result := '';
  finally
    LRegistry.Free;
  end;
end;

procedure THostPreviewHandler.LoadPreviewHandler;
const
  GUID_ISHELLITEM = '{43826d1e-e718-42ee-bc55-a1e261c37bfe}';
var
  prc                   : TRect;
  LPreviewGUID          : TGUID;
  LInitializeWithFile   : IInitializeWithFile;
  LInitializeWithStream : IInitializeWithStream;
  LInitializeWithItem   : IInitializeWithItem;
  LIStream              : IStream;
  LShellItem            : IShellItem;
begin

  FLoaded:=False;
  FPreviewGUIDStr:=GetPreviewHandlerCLSID(FFileName);
  if FPreviewGUIDStr='' then exit;

  if FFileStream<>nil then
    FFileStream.Free;

  LPreviewGUID:= StringToGUID(FPreviewGUIDStr);

  FPreviewHandler := CreateComObject(LPreviewGUID) As IPreviewHandler;
  if (FPreviewHandler = nil) then
    exit;

  if FPreviewHandler.QueryInterface(IInitializeWithFile, LInitializeWithFile) = S_OK then
    LInitializeWithFile.Initialize(StringToOleStr(FFileName), STGM_READ)
  else
  if FPreviewHandler.QueryInterface(IInitializeWithStream, LInitializeWithStream) = S_OK then
  begin
      FFileStream := TFileStream.Create(FFileName, fmOpenRead or fmShareDenyNone);
      LIStream := TStreamAdapter.Create(FFileStream, soOwned) as IStream;
      LInitializeWithStream.Initialize(LIStream, STGM_READ);
  end
  else
  if FPreviewHandler.QueryInterface(IInitializeWithItem, LInitializeWithItem) = S_OK then
  begin
    SHCreateItemFromParsingName(PChar(FileName), nil, StringToGUID(GUID_ISHELLITEM), LShellItem);
    LInitializeWithItem.Initialize(LShellItem, 0);
  end
  else
  begin
    FPreviewHandler.Unload;
    FPreviewHandler:=nil;
    exit;
  end;

  prc := ClientRect;
  FPreviewHandler.SetWindow(Self.Handle, prc);
end;

procedure THostPreviewHandler.SetFileName(const Value: string);
begin
  FFileName := Value;
  HandleNeeded;
  LoadPreviewHandler;
end;

procedure THostPreviewHandler.WMSize(var Message: TWMSize);
var
  prc  : TRect;
begin
  inherited;
  if FPreviewHandler<>nil then
  begin
    prc := ClientRect;
    FPreviewHandler.SetRect(prc);
  end;
end;

end.

And you can use it in this way

  FPreview := THostPreviewHandler.Create(Self);
  FPreview.Top := 0;
  FPreview.Left := 0;
  FPreview.Width  := Panel1.ClientWidth;
  FPreview.Height := Panel1.ClientHeight;
  FPreview.Parent := Panel1;
  FPreview.Align  := alClient;
  FPreview.FileName:=FileName;

This is a sample image of a preview handler hosted in a VCL Application.

previewhost


Check the source code on Github.


3 Comments

Exploring Delphi XE3 – WinApi Additions – Winapi.Functiondiscovery Part 3

This is the part 3 of the Exploring Delphi XE3 – WinApi Additions – Winapi.Functiondiscovery Article.

The Function Discovery API can be used not just for enumerate devices also you can receive notifications as well, like when a device is added, removed or a property of the device is modified. In order to receive such notifications you must implement the IFunctionDiscoveryNotification interface and pass a instance of this implementation to the CreateInstanceCollectionQuery method, then you must restrict the result of the query with the method AddQueryConstraint passing the PROVIDERPNP_QUERYCONSTRAINT_NOTIFICATIONSONLY value to only receive notifications and finally call the IFunctionInstanceCollectionQuery.Execute method.

Implementing the IFunctionDiscoveryNotification interface

The IFunctionDiscoveryNotification interface exposes 3 methods to receive the results of the asynchronous queries returned by the execution of the IFunctionInstanceCollectionQuery.Execute method.

OnError Receives errors that occur during asynchronous query processing.
OnEvent Receives any add, remove, or update events.
OnUpdate Indicates that a function instance has been added, removed, or changed.

This is the Delphi declaration of the IFunctionDiscoveryNotification interface.

IFunctionDiscoveryNotification = interface(IUnknown)
[SID_IFunctionDiscoveryNotification]
  function OnUpdate(enumQueryUpdateAction: QueryUpdateAction; fdqcQueryContext: FDQUERYCONTEXT; pIFunctionInstance: IFunctionInstance): HRESULT; stdcall;
  function OnError(hr: HRESULT; fdqcQueryContext: FDQUERYCONTEXT; pszProvider: PWCHAR): HRESULT; stdcall;
  function OnEvent(dwEventID: DWORD; fdqcQueryContext: FDQUERYCONTEXT; pszProvider: PWCHAR): HRESULT; stdcall;
end;

Now check this Delphi implementation for the IFunctionDiscoveryNotification interface.

type
  TFunctionDiscoveryOnUpdate = procedure(enumQueryUpdateAction: QueryUpdateAction; fdqcQueryContext: FDQUERYCONTEXT;
      pIFunctionInstance: IFunctionInstance) of object;
  TFunctionDiscoveryOnError  = procedure(hr: HRESULT; fdqcQueryContext: FDQUERYCONTEXT; pszProvider: PWCHAR) of object;
  TFunctionDiscoveryOnEvent  = procedure(dwEventID: DWORD; fdqcQueryContext: FDQUERYCONTEXT; pszProvider: PWCHAR) of object;

  TFunctionDiscoveryNotificationSync=class(TInterfacedObject, IFunctionDiscoveryNotification)
  private
    FAction        : QueryUpdateAction;
    FEventAdd      : TEvent;
    FEventRemove   : TEvent;
    FEventChange   : TEvent;
    FOnUpdateEvent : TFunctionDiscoveryOnUpdate;
    FOnErrorEvent  : TFunctionDiscoveryOnError;
    FOnEventEvent  : TFunctionDiscoveryOnEvent;
    function OnUpdate(enumQueryUpdateAction: QueryUpdateAction; fdqcQueryContext: FDQUERYCONTEXT;
      pIFunctionInstance: IFunctionInstance): HRESULT; stdcall;
    function OnError(hr: HRESULT; fdqcQueryContext: FDQUERYCONTEXT; pszProvider: PWCHAR): HRESULT; stdcall;
    function OnEvent(dwEventID: DWORD; fdqcQueryContext: FDQUERYCONTEXT; pszProvider: PWCHAR): HRESULT; stdcall;
  public
    constructor Create;
    destructor Destroy; override;
    function WaitFor(dwTimeout : DWORD; pszCategory: PWCHAR; eAction : QueryUpdateAction) : HRESULT;
    property OnUpdateEvent: TFunctionDiscoveryOnUpdate read FOnUpdateEvent write FOnUpdateEvent;
    property OnErrorEvent : TFunctionDiscoveryOnError read FOnErrorEvent write FOnErrorEvent;
    property OnEventEvent : TFunctionDiscoveryOnEvent read FOnEventEvent write FOnEventEvent;
  end;


{TFunctionDiscoveryNotificationSync}

constructor TFunctionDiscoveryNotificationSync.Create;
begin
  inherited;
  FOnUpdateEvent:=nil;
  //create the  events objects
  FEventAdd    := TEvent.Create(nil, False, False, '', true);
  FEventRemove := TEvent.Create(nil, False, False, '', true);
  FEventChange := TEvent.Create(nil, False, False, '', true);
end;

destructor TFunctionDiscoveryNotificationSync.Destroy;
begin
  //release the event objects
  FEventAdd.Free;
  FEventRemove.Free;
  FEventChange.Free;
  inherited;
end;

function TFunctionDiscoveryNotificationSync.OnError(hr: HRESULT;
  fdqcQueryContext: FDQUERYCONTEXT; pszProvider: PWCHAR): HRESULT;
begin
   //send the error notification if a callback method  was defined
   if @FOnErrorEvent<>nil then
    FOnErrorEvent(hr, fdqcQueryContext, pszProvider);
   Exit(S_OK);
end;

function TFunctionDiscoveryNotificationSync.OnEvent(dwEventID: DWORD;
  fdqcQueryContext: FDQUERYCONTEXT; pszProvider: PWCHAR): HRESULT;
begin
   //send the OnEvent notification if a callback method  was defined
   if @FOnEventEvent<>nil then
    FOnEventEvent(dwEventID, fdqcQueryContext, pszProvider);
   Exit(S_OK);
end;

function TFunctionDiscoveryNotificationSync.OnUpdate(
  enumQueryUpdateAction: QueryUpdateAction; fdqcQueryContext: FDQUERYCONTEXT;
  pIFunctionInstance: IFunctionInstance): HRESULT;
begin

    //signal the event object
    case enumQueryUpdateAction of
      QUA_ADD    : FEventAdd.SetEvent;
      QUA_REMOVE : FEventRemove.SetEvent;
      QUA_CHANGE : FEventChange.SetEvent;
    end;

   //send the OnEvent notification if a callback method  was defined
   if (@FOnUpdateEvent<>nil) and (FAction=enumQueryUpdateAction) then
    FOnUpdateEvent(enumQueryUpdateAction, fdqcQueryContext, pIFunctionInstance);
   Exit(S_OK);
end;

function TFunctionDiscoveryNotificationSync.WaitFor(dwTimeout : DWORD; pszCategory: PWCHAR; eAction : QueryUpdateAction) : HRESULT;
var
 hr : HRESULT;
 LEvent : TEvent;
 LWaitResult : TWaitResult;
 FFunctionDiscovery : IFunctionDiscovery;
 ppIFunctionInstanceCollection: IFunctionInstanceCollection;
 ppIFunctionInstanceCollectionQuery: IFunctionInstanceCollectionQuery;
begin
 FAction:=eAction;
 //reset the event objects
 FEventAdd.ResetEvent;
 FEventRemove.ResetEvent;
 FEventChange.ResetEvent;

 //create a instance to the IFunctionDiscovery
 FFunctionDiscovery := CreateComObject(CLSID_FunctionDiscovery) as IFunctionDiscovery;
 //create a new query passing the current class as callback
 hr := FFunctionDiscovery.CreateInstanceCollectionQuery(FCTN_CATEGORY_PNP, nil, true, Self, nil, ppIFunctionInstanceCollectionQuery);

 //instruct to the query to only receive notifications
 if hr=S_OK then
   hr := ppIFunctionInstanceCollectionQuery.AddQueryConstraint(PROVIDERPNP_QUERYCONSTRAINT_NOTIFICATIONSONLY,'TRUE');

 //execute the query
 if hr=S_OK then
   hr := ppIFunctionInstanceCollectionQuery.Execute(ppIFunctionInstanceCollection);

 if( hr=E_PENDING) then hr := S_OK;

    case eAction of
      QUA_ADD    : LEvent:=FEventAdd;
      QUA_REMOVE : LEvent:=FEventRemove;
      QUA_CHANGE : LEvent:=FEventChange;
      else
      LEvent := nil;
    end;

  if (hr=S_OK) and (LEvent<>nil) then
   LWaitResult:= LEvent.WaitFor(dwTimeout);

 // One device may correspond to multiple function instances
 // This sleep allows the OnUpdate call to output information
 // about each Function Instance.
 // THIS SLEEP IS MERELY FOR DISPLAY PURPOSES
 Sleep(1000);
 Exit(hr);
end;

Demo Application

Now using the above implementation we can receive notification about the devices, you can test the next sample app inserting a USB device and then removing.


type  
 TNotifier=class
    procedure  OnUpdate(enumQueryUpdateAction: QueryUpdateAction; fdqcQueryContext: FDQUERYCONTEXT;
      pIFunctionInstance: IFunctionInstance);
  end;

procedure NotificationDemo;
Const
  Timeout = 20000;
var
  hr : HResult;
  pIFunctionDiscoveryNotification : TFunctionDiscoveryNotificationSync;
  LNotifier : TNotifier;
begin
 LNotifier:=TNotifier.Create;
 try
   pIFunctionDiscoveryNotification:=TFunctionDiscoveryNotificationSync.Create;
   try
       //set the callback
       pIFunctionDiscoveryNotification.OnUpdateEvent:=LNotifier.OnUpdate;
       Writeln(Format('Waiting for %d ms, to plug in a PnP device',[Timeout]));
       pIFunctionDiscoveryNotification.WaitFor(Timeout, FCTN_CATEGORY_PNP, QUA_ADD);
       Writeln('Done');
   finally
     pIFunctionDiscoveryNotification:=nil;
   end;

   pIFunctionDiscoveryNotification:=TFunctionDiscoveryNotificationSync.Create;
   try
       //set the callback
       pIFunctionDiscoveryNotification.OnUpdateEvent:=LNotifier.OnUpdate;
       Writeln(Format('Waiting for %d ms, to remove a PnP device',[Timeout]));
       pIFunctionDiscoveryNotification.WaitFor(Timeout, FCTN_CATEGORY_PNP, QUA_REMOVE);
       Writeln('Done');
   finally
     pIFunctionDiscoveryNotification:=nil;
   end;
 finally
     LNotifier.Free;
 end;
end;

{ TNotifier }
procedure TNotifier.OnUpdate(enumQueryUpdateAction: QueryUpdateAction;
  fdqcQueryContext: FDQUERYCONTEXT; pIFunctionInstance: IFunctionInstance);
var
  ppIPropertyStore  : IPropertyStore;
  pv : TPropVariant;
begin
  case enumQueryUpdateAction of
    QUA_ADD    : Writeln(Format('Action : %s',['Add']));
    QUA_REMOVE : Writeln(Format('Action : %s',['Remove']));
    QUA_CHANGE : Writeln(Format('Action : %s',['Change']));
  end;
  if Succeeded(pIFunctionInstance.OpenPropertyStore(STGM_READ, ppIPropertyStore)) then
    if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_DeviceDesc, pv)) then
      Writeln(Format('Device Desc. %s',[pv.pwszVal]));
    if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_Class, pv)) then
      Writeln(Format('Class        %s',[pv.pwszVal]));
    if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_Manufacturer, pv)) then
      Writeln(Format('Manufacturer %s',[pv.pwszVal]));
end;

begin
 try
   ReportMemoryLeaksOnShutdown:=True;
   if (Win32MajorVersion >= 6) then  // available on Vista (or later)
   begin
    if Succeeded(CoInitializeEx(nil, COINIT_MULTITHREADED)) then
    try
     NotificationDemo;
    finally
      CoUninitialize;
    end;
   end
   else
   Writeln('Windows version not compatible');
 except
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Writeln('Press Enter to exit');
 Readln;
end.


1 Comment

Exploring Delphi XE3 – WinApi Additions – Winapi.Functiondiscovery Part 2

This is the part 2 of the Exploring Delphi XE3 – WinApi Additions – Winapi.Functiondiscovery Article

One of the nice features of the Function Discovery API is the posibility of filter the results for device enumeration, for this you must use the CreateInstanceCollectionQuery method and then add the conditions for the query using the AddPropertyConstraint method.

Try this sample Delphi code which enumerates all the processors devices where the manufacturer is Intel.

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.Win.ComObj,
  Winapi.Windows,
  Winapi.Activex,
  Winapi.PropSys,
  Winapi.Functiondiscovery,
  System.SysUtils;

procedure Enumerate;
var
    LFunctionDiscovery : IFunctionDiscovery;
    LFunctionInstance  : IFunctionInstance;
    ppIFunctionInstanceCollection: IFunctionInstanceCollection;
    ppIFunctionInstanceCollectionQuery: IFunctionInstanceCollectionQuery;
    ppIPropertyStore  : IPropertyStore;
    pv : TPropVariant;
    pdwCount : DWORD;
    pszCategory: PWCHAR;
    hr : HResult;
    i : integer;
begin
  //create an instance to the  IFunctionDiscovery interface
  LFunctionDiscovery := CreateComObject(CLSID_FunctionDiscovery) as IFunctionDiscovery;
  try
    //set the provider to search
    pszCategory:=FCTN_CATEGORY_PNP;
    //get the devices collection
    hr := LFunctionDiscovery.CreateInstanceCollectionQuery(pszCategory, nil, false, nil, nil, ppIFunctionInstanceCollectionQuery);
      if Succeeded(hr)  then
      begin
       PropVariantClear(pv);
       pv.vt:=VT_LPWSTR;
       pv.pwszVal:='Intel';
       hr := ppIFunctionInstanceCollectionQuery.AddPropertyConstraint(PKEY_Device_Manufacturer, pv, QC_EQUALS);
       if not Succeeded(hr) then RaiseLastOSError;

       PropVariantClear(pv);
       pv.vt:=VT_LPWSTR;
       pv.pwszVal:='Processor';
       hr := ppIFunctionInstanceCollectionQuery.AddPropertyConstraint(PKEY_Device_Class, pv, QC_EQUALS);
       if not Succeeded(hr) then RaiseLastOSError;

        hr := ppIFunctionInstanceCollectionQuery.Execute(ppIFunctionInstanceCollection);
        if Succeeded(hr)  then
        begin
          //get the collection count
          ppIFunctionInstanceCollection.GetCount(pdwCount);
          if pdwCount=0 then
            Writeln(Format('No items was found for the %s category',[pszCategory]))
          else
          for i := 0 to pdwCount - 1 do begin
            //get the n Item of the collection
            if Succeeded(ppIFunctionInstanceCollection.Item(i, LFunctionInstance)) then
            begin
              //init the propertiess store
              LFunctionInstance.OpenPropertyStore(STGM_READ, ppIPropertyStore);
              //read the properties values
              if Succeeded(ppIPropertyStore.GetValue(PKEY_NAME, pv)) then
               Writeln(Format('Name          %s',[pv.pwszVal]));
              if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_InstanceId, pv)) then
               Writeln(Format('Instance Id   %s',[pv.pwszVal]));
              if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_Driver, pv)) then
               Writeln(Format('Device Driver %s',[pv.pwszVal]));
              if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_Model, pv)) then
               Writeln(Format('Model         %s',[pv.pwszVal]));
              if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_Manufacturer, pv)) then
               Writeln(Format('Manufacturer  %s',[pv.pwszVal]));
              if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_LocationInfo, pv)) then
               Writeln(Format('Location      %s',[pv.pwszVal]));
              if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_Class, pv)) then
               Writeln(Format('Class        %s',[pv.pwszVal]));
              if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_ClassGuid, pv)) then
               Writeln(Format('Class Guid   %s',[pv.puuid^.ToString]));
              Writeln;
            end
            else
             RaiseLastOSError;
           end;
        end;
      end
      else
       RaiseLastOSError;
  finally
    LFunctionDiscovery:=nil;
  end;
end;

begin
 try
   ReportMemoryLeaksOnShutdown:=True;
   if (Win32MajorVersion >= 6) then  // available on Vista (or later)
   begin
    if Succeeded(CoInitializeEx(nil, COINIT_MULTITHREADED)) then
    try
     Enumerate;
    finally
      CoUninitialize;
    end;
   end
   else
   Writeln('Windows version not compatible');
 except
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Writeln('Press Enter to exit');
 Readln;
end.


4 Comments

Exploring Delphi XE3 – WinApi Additions – Winapi.Functiondiscovery Part 1

Starting with Windows Vista The SetupDi and the WMI are not longer the only APIs to enumerate devices and receive notifications about hardware changes, with the introduction of the Function Discovery API you can access the installed devices using a unified API and interfaces for gathering functionality, properties, and notifications from various device types like PnP, PnP-X, Registry, NetBIOS and custom (third-party) providers.

Delphi XE3 include the translation of the headers for the Function Discovery API in the Winapi.Functiondiscovery unit. In this post I will show the basic code to enumerate the hardware devices.

To get a collection of the devices (function instances), you must use use the IFunctionDiscovery.GetInstanceCollection method. from here to get each function instance in the collection in order, use the IFunctionInstanceCollection.Item method and finally use the IFunctionInstance.OpenPropertyStore and IPropertyStore.GetValue methods to retrieve the value of each property.

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.Win.ComObj,
  Winapi.Windows,
  Winapi.Activex,
  Winapi.PropSys,
  Winapi.Functiondiscovery,
  System.SysUtils;

procedure Enumerate;
var
    LFunctionDiscovery : IFunctionDiscovery;
    hr : HResult;
    i : integer;
    LFunctionInstance : IFunctionInstance;
    ppIFunctionInstanceCollection : IFunctionInstanceCollection;
    ppIPropertyStore  : IPropertyStore;
    pv : TPropVariant;
    pdwCount : DWORD;
    pszCategory: PWCHAR;
begin
  //create an instance to the  IFunctionDiscovery interface
  LFunctionDiscovery := CreateComObject(CLSID_FunctionDiscovery) as IFunctionDiscovery;
  try
    //set the provider to search
    pszCategory:=FCTN_CATEGORY_PNP;
    //get the devices collection
    hr := LFunctionDiscovery.GetInstanceCollection(pszCategory, nil, true, ppIFunctionInstanceCollection);
      //get the collection count
      if Succeeded(hr) and Succeeded(ppIFunctionInstanceCollection.GetCount(pdwCount)) then
      begin
        if pdwCount=0 then
          Writeln(Format('No items was found for the %s category',[pszCategory]))
        else
        for i := 0 to pdwCount - 1 do begin
          //get the n Item of the collection
          if Succeeded(ppIFunctionInstanceCollection.Item(i, LFunctionInstance)) then
          begin
            //init the propertiess store
            LFunctionInstance.OpenPropertyStore(STGM_READ, ppIPropertyStore);
            //read the properties values
            if Succeeded(ppIPropertyStore.GetValue(PKEY_NAME, pv)) then
             Writeln(Format('Name          %s',[pv.pwszVal]));
            if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_InstanceId, pv)) then
             Writeln(Format('Instance Id   %s',[pv.pwszVal]));
            if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_Driver, pv)) then
             Writeln(Format('Device Driver %s',[pv.pwszVal]));
            if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_Model, pv)) then
             Writeln(Format('Model         %s',[pv.pwszVal]));
            if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_Manufacturer, pv)) then
             Writeln(Format('Manufacturer  %s',[pv.pwszVal]));
            if Succeeded(ppIPropertyStore.GetValue(PKEY_Device_LocationInfo, pv)) then
             Writeln(Format('Location      %s',[pv.pwszVal]));
            Writeln;
          end
          else
           RaiseLastOSError;
        end;
      end
      else
       RaiseLastOSError;
  finally
    LFunctionDiscovery:=nil;
  end;
end;

begin
 try
   if (Win32MajorVersion >= 6) then  // available on Vista (or later)
   begin
    if Succeeded(CoInitializeEx(nil, COINIT_MULTITHREADED)) then
    try
     Enumerate;
    finally
      CoUninitialize;
    end;
   end
   else
   Writeln('Windows version not compatible');
 except
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Writeln('Press Enter to exit');
 Readln;
end.

As you can see the code is very straightforward, Now the next sample show how retrieves all the properties of each device.

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.Win.ComObj,
  Winapi.Windows,
  Winapi.Activex,
  Winapi.PropSys,
  Winapi.Functiondiscovery,
  System.Generics.Collections,
  System.SysUtils;

procedure Enumerate2;
var
    LFunctionDiscovery : IFunctionDiscovery;
    hr : HResult;
    i,j : integer;
    LFunctionInstance : IFunctionInstance;
    ppIFunctionInstanceCollection : IFunctionInstanceCollection;
    ppIPropertyStore  : IPropertyStore;
    pv : TPropVariant;
    pdwCount : DWORD;
    cProps: DWORD;
    pszCategory: PWCHAR;
    pkey: TPropertyKey;
    ListKeys : TDictionary<TPropertyKey, string>;
    KeyName : string;
begin
  //create a list with TPropertyKey descriptions
  ListKeys:=TDictionary<TPropertyKey, string>.Create;
  try
    ListKeys.Add(PKEY_NAME, 'Name');
{ Device properties }
{ These PKEYs correspond to the old setupapi SPDRP_XXX properties }
    ListKeys.Add(PKEY_Device_DeviceDesc, 'Device Desc');
    ListKeys.Add(PKEY_Device_HardwareIds, 'Hardware Id');
    ListKeys.Add(PKEY_Device_CompatibleIds, 'Compatible Id');
    ListKeys.Add(PKEY_Device_Service, 'Device Service');
    ListKeys.Add(PKEY_Device_Class, 'Class');
    ListKeys.Add(PKEY_Device_ClassGuid, 'Class GUID');
    ListKeys.Add(PKEY_Device_ConfigFlags, 'ConfigFlags');
    ListKeys.Add(PKEY_Device_Manufacturer, 'Manufacturer');
    ListKeys.Add(PKEY_Device_FriendlyName, 'Friendly Name');
    ListKeys.Add(PKEY_Device_LocationInfo, 'Location Info');
    ListKeys.Add(PKEY_Device_PDOName, 'PDO Name');
    ListKeys.Add(PKEY_Device_Capabilities, 'Capabilities');
    ListKeys.Add(PKEY_Device_UINumber, 'UI Number');
    ListKeys.Add(PKEY_Device_UpperFilters, 'Upper Filters');
    ListKeys.Add(PKEY_Device_LowerFilters, 'Lower Filters');
    ListKeys.Add(PKEY_Device_BusTypeGuid, 'Bus Type Guid');
    ListKeys.Add(PKEY_Device_LegacyBusType, 'Legacy Bus Type');
    ListKeys.Add(PKEY_Device_BusNumber, 'Bus Number');
    ListKeys.Add(PKEY_Device_EnumeratorName, 'Enumerator Name');
    ListKeys.Add(PKEY_Device_Security, 'Security');
    ListKeys.Add(PKEY_Device_SecuritySDS, 'Security SDS');
    ListKeys.Add(PKEY_Device_DevType, 'Dev Type');
    ListKeys.Add(PKEY_Device_Exclusive, 'Exclusive');
    ListKeys.Add(PKEY_Device_Characteristics, 'Characteristics');
    ListKeys.Add(PKEY_Device_Address, 'Address');
    ListKeys.Add(PKEY_Device_UINumberDescFormat, 'UI Number Desc. Format');
    ListKeys.Add(PKEY_Device_PowerData, 'Power Data');
    ListKeys.Add(PKEY_Device_RemovalPolicy, 'Removal Policy');
    ListKeys.Add(PKEY_Device_RemovalPolicyDefault, 'Removal Policy Default');
    ListKeys.Add(PKEY_Device_RemovalPolicyOverride, 'Removal Policy Override');
    ListKeys.Add(PKEY_Device_InstallState, 'Install State');
    ListKeys.Add(PKEY_Device_LocationPaths, 'Location Paths');
    ListKeys.Add(PKEY_Device_BaseContainerId, 'BaseContainer Id');
{ Device properties }
{ These PKEYs correspond to a device's status and problem code }

    ListKeys.Add(PKEY_Device_DevNodeStatus, 'Dev Node Status');
    ListKeys.Add(PKEY_Device_ProblemCode, 'Problem Code');
{ Device properties }
{ These PKEYs correspond to device relations }

    ListKeys.Add(PKEY_Device_EjectionRelations, 'Ejection Relations');
    ListKeys.Add(PKEY_Device_RemovalRelations, 'Removal Relations');
    ListKeys.Add(PKEY_Device_PowerRelations, 'Power Relations');
    ListKeys.Add(PKEY_Device_BusRelations, 'Bus Relations');
    ListKeys.Add(PKEY_Device_Parent, 'Parent');
    ListKeys.Add(PKEY_Device_Children, 'Children');
    ListKeys.Add(PKEY_Device_Siblings, 'Sibling');
    ListKeys.Add(PKEY_Device_TransportRelations, 'Transport Relations');
{ Other Device properties }
    ListKeys.Add(PKEY_Device_Reported, 'Reported');
    ListKeys.Add(PKEY_Device_Legacy, 'Legacy');
    ListKeys.Add(PKEY_Device_InstanceId, 'Instance Id');
    ListKeys.Add(PKEY_Device_ContainerId, 'Container Id');
    ListKeys.Add(PKEY_Device_ModelId, 'Model Id');
    ListKeys.Add(PKEY_Device_FriendlyNameAttributes, 'Friendly Name Attributes');
    ListKeys.Add(PKEY_Device_ManufacturerAttributes, 'Manufacturer Attributes');
    ListKeys.Add(PKEY_Device_PresenceNotForDevice, 'Presence Not For Device');
    ListKeys.Add(PKEY_Numa_Proximity_Domain, 'Numa Proximity Domain');
    ListKeys.Add(PKEY_Device_DHP_Rebalance_Policy, 'DHP Rebalance Policy');
    ListKeys.Add(PKEY_Device_Numa_Node, 'Numa Node');
    ListKeys.Add(PKEY_Device_BusReportedDeviceDesc, 'Bus Reported Device Desc');
    ListKeys.Add(PKEY_Device_InstallInProgress, 'Install In Progress');
{ Device driver properties }
    ListKeys.Add(PKEY_Device_DriverDate, 'Driver Date');
    ListKeys.Add(PKEY_Device_DriverVersion, 'Driver Version');
    ListKeys.Add(PKEY_Device_DriverDesc, 'Driver Desc');
    ListKeys.Add(PKEY_Device_DriverInfPath, 'Driver Inf Path');
    ListKeys.Add(PKEY_Device_DriverInfSection, 'Driver Inf Section');
    ListKeys.Add(PKEY_Device_DriverInfSectionExt, 'Driver Inf Section Ext');
    ListKeys.Add(PKEY_Device_MatchingDeviceId, 'Matching DeviceId');
    ListKeys.Add(PKEY_Device_DriverProvider, 'Driver Provider');
    ListKeys.Add(PKEY_Device_DriverPropPageProvider, 'Driver Prop Page Provider');
    ListKeys.Add(PKEY_Device_DriverCoInstallers, 'Driver CoInstallers');
    ListKeys.Add(PKEY_Device_ResourcePickerTags, 'Resource Picker Tags');
    ListKeys.Add(PKEY_Device_ResourcePickerExceptions, 'Resource Picker Exceptions');
    ListKeys.Add(PKEY_Device_DriverRank, 'Driver Rank');
    ListKeys.Add(PKEY_Device_DriverLogoLevel, 'Driver Logo Level');
    ListKeys.Add(PKEY_Device_NoConnectSound, 'No Connect Sound');
    ListKeys.Add(PKEY_Device_GenericDriverInstalled, 'Generic Driver Installed');
    ListKeys.Add(PKEY_Device_AdditionalSoftwareRequested, 'Additional Software Requested');
{Add more TPropertyKey here}

      //create a instance for the IFunctionDiscovery interface
      LFunctionDiscovery := CreateComObject(CLSID_FunctionDiscovery) as IFunctionDiscovery;
      try
        //set the provider
        pszCategory:=FCTN_CATEGORY_PNP;
        //get all the instances for the current provider
        hr := LFunctionDiscovery.GetInstanceCollection(pszCategory, nil, true, ppIFunctionInstanceCollection);
        if Succeeded(hr) then
          if Succeeded(ppIFunctionInstanceCollection.GetCount(pdwCount)) then
          begin
            if pdwCount=0 then
              Writeln(Format('No items was found for the %s category',[pszCategory]))
            else
            for i := 0 to pdwCount - 1 do begin
              if Succeeded(ppIFunctionInstanceCollection.Item(i, LFunctionInstance)) then
              begin
                //open the properties
                if Succeeded(LFunctionInstance.OpenPropertyStore(STGM_READ, ppIPropertyStore)) then
                begin
                   //get the num of properties for the current instance
                   ppIPropertyStore.GetCount(cProps);
                   for j := 0 to cProps - 1 do
                   begin
                      //get the TPropertyKey for the current index
                     if Succeeded(ppIPropertyStore.GetAt(j, pkey)) then
                      // get the value for the curent  TPropertyKey
                      if Succeeded(ppIPropertyStore.GetValue(pkey, pv)) then
                      begin
                       //resolves the key description or use the TGUID if is not found
                       KeyName:=pkey.fmtid.ToString;
                       if ListKeys.ContainsKey(pkey) then
                         KeyName:=ListKeys.Items[pkey];

                       //depending of the type of the property display the info
                       case pv.vt of
                         VT_BOOL    : Writeln(Format('%-40s %s',[KeyName , BoolToStr(pv.boolVal, True)]));
                         VT_UINT    : Writeln(Format('%-40s %d',[KeyName ,pv.ulVal]));
                         VT_INT     : Writeln(Format('%-40s %d',[KeyName ,pv.iVal]));
                         VT_I4,
                         VT_UI4     : Writeln(Format('%-40s %d',[KeyName ,pv.ulVal]));
                         VT_EMPTY   : Writeln(Format('%-40s %s',[KeyName ,'(Empty)']));
                         VT_LPWSTR  : Writeln(Format('%-40s %s',[KeyName ,pv.pwszVal]));
                         VT_CLSID   : Writeln(Format('%-40s %s',[KeyName ,pv.puuid^.ToString]));
                       else
                                    Writeln(Format('%-40s %s',[KeyName ,'(Type Unknow)']));
                       end;

                       PropVariantClear(pv);
                      end;
                   end;
                   Writeln;
                end;
              end
              else
               RaiseLastOSError;
            end;
          end
          else
           RaiseLastOSError
        else
         RaiseLastOSError;
      finally
        LFunctionDiscovery:=nil;
      end;
  finally
     ListKeys.Free;
  end;
end;


begin
 try
   if (Win32MajorVersion >= 6) then  // available on Vista (or later)
   begin
    if Succeeded(CoInitializeEx(nil, COINIT_MULTITHREADED)) then
    try
     Enumerate2;
    finally
      CoUninitialize;
    end;
   end
   else
   Writeln('Windows version not compatible');
 except
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Writeln('Press Enter to exit');
 Readln;
end.

This is just a basic sample of the use of the Function Discovery API, in the next post I will show another features of this API.


9 Comments

Exploring Delphi XE3 – WinApi Additions – Winapi.Wbem

Delphi XE3 introduces a lot of new WinApi headers translations, between them is the Winapi.Wbem unit which is the Delphi (object pascal) translation for the wbemidl.h file which contains the WMI Component Object Model (COM) interface definitions. This means that from now you can access the WMI in a fastest way and directly using COM avoiding the use of the Microsoft WMIScripting Library and third party libraries.

Try this sample Delphi XE3 console application which access the Win32_Process WMI Class using the Winapi.Wbem unit.

{$APPTYPE CONSOLE}

{$R *.res}

uses
  Winapi.Windows,
  System.SysUtils,
  Winapi.ActiveX,
  Winapi.Wbem;

const
  //Impersonation Level Constants
  //http://msdn.microsoft.com/en-us/library/ms693790%28v=vs.85%29.aspx
  RPC_C_AUTHN_LEVEL_DEFAULT   = 0;
  RPC_C_IMP_LEVEL_ANONYMOUS   = 1;
  RPC_C_IMP_LEVEL_IDENTIFY    = 2;
  RPC_C_IMP_LEVEL_IMPERSONATE = 3;
  RPC_C_IMP_LEVEL_DELEGATE    = 4;

  //Authentication Service Constants
  //http://msdn.microsoft.com/en-us/library/ms692656%28v=vs.85%29.aspx
  RPC_C_AUTHN_WINNT      = 10;
  RPC_C_AUTHN_LEVEL_CALL = 3;
  RPC_C_AUTHN_DEFAULT    = Longint($FFFFFFFF);
  EOAC_NONE              = 0;

  //Authorization Constants
  //http://msdn.microsoft.com/en-us/library/ms690276%28v=vs.85%29.aspx
  RPC_C_AUTHZ_NONE       = 0;
  RPC_C_AUTHZ_NAME       = 1;
  RPC_C_AUTHZ_DCE        = 2;
  RPC_C_AUTHZ_DEFAULT    = Longint($FFFFFFFF);

  //Authentication-Level Constants
  //http://msdn.microsoft.com/en-us/library/aa373553%28v=vs.85%29.aspx
  RPC_C_AUTHN_LEVEL_PKT_PRIVACY   = 6;
  SEC_WINNT_AUTH_IDENTITY_UNICODE = 2;

 //COAUTHIDENTITY Structure
 //http://msdn.microsoft.com/en-us/library/ms693358%28v=vs.85%29.aspx
 type
    PCOAUTHIDENTITY    = ^TCOAUTHIDENTITY;
    _COAUTHIDENTITY    = Record
                          User           : PChar;
                          UserLength     : ULONG;
                          Domain         : PChar;
                          DomainLength   : ULONG;
                          Password       : PChar;
                          PassWordLength : ULONG;
                          Flags          : ULONG;
                          End;

   COAUTHIDENTITY      = _COAUTHIDENTITY;
   TCOAUTHIDENTITY     = _COAUTHIDENTITY;



function GetExtendedErrorInfo(hresErr: HRESULT):Boolean;
var
 pStatus    : IWbemStatusCodeText;
 hres       : HRESULT;
 MessageText: WideString;
begin
  Result:=False;
    hres := CoCreateInstance(CLSID_WbemStatusCodeText, nil, CLSCTX_INPROC_SERVER, IID_IWbemStatusCodeText, pStatus);
    if (hres = S_OK) then
    begin
     hres := pStatus.GetErrorCodeText(hresErr, 0, 0, MessageText);
     if(hres <> S_OK) then
       MessageText := 'Get last error failed';

     Result:=(hres = S_OK);
     if Result then
      Writeln(Format( 'ErrorCode %x Description %s',[hresErr,MessageText]));
    end;
end;


procedure  TestWbem;
const
  WbemUser            ='';
  WbemPassword        ='';
  WbemComputer        ='localhost';
  WbemLocale          ='';
  WbemAuthority       ='kERBEROS:'+WbemComputer;
var
  LWbemLocator         : IWbemLocator;
  LWbemServices        : IWbemServices;
  LUnsecuredApartment  : IUnsecuredApartment;
  ppEnum               : IEnumWbemClassObject;
  apObjects            : IWbemClassObject;
  puReturned           : ULONG;
  pVal                 : Variant;
  pType                : PCIMTYPE;
  plFlavor             : PInteger;
  OpResult             : HRESULT;
  LocalConnection      : Boolean;
  AuthInfo             : TCOAUTHIDENTITY;
begin
  ZeroMemory(@AuthInfo, 0);
  with AuthInfo do
  begin
    User           := PChar(WbemUser);
    UserLength     := Length(WbemUser);
    Domain         := '';
    DomainLength   := 0;
    Password       := PChar(WbemPassword);
    PasswordLength := Length(WbemPassword);
    Flags          := SEC_WINNT_AUTH_IDENTITY_UNICODE;
  end;

  LocalConnection:=WbemComputer.IsEmpty or (WbemComputer.CompareTo('localhost')=0);
  if LocalConnection then
   if Failed(CoInitializeSecurity(nil, -1, nil, nil, RPC_C_AUTHN_LEVEL_DEFAULT, RPC_C_IMP_LEVEL_IMPERSONATE, nil, EOAC_NONE, nil)) then Exit
   else
  else
   if Failed(CoInitializeSecurity(nil, -1, nil, nil, RPC_C_AUTHN_LEVEL_DEFAULT, RPC_C_IMP_LEVEL_IDENTIFY, nil, EOAC_NONE, nil)) then Exit;


  OpResult:=CoCreateInstance(CLSID_WbemLocator, nil, CLSCTX_INPROC_SERVER, IID_IWbemLocator, LWbemLocator);
  if Succeeded(OpResult) then
  begin
    try
      Writeln('Connecting to the WMI Service');
      if LocalConnection then
        OpResult:=LWbemLocator.ConnectServer(Format('\\%s\root\CIMV2',[WbemComputer]), WbemUser, WbemPassword, WbemLocale,  WBEM_FLAG_CONNECT_USE_MAX_WAIT, '', nil, LWbemServices)
      else
        OpResult:=LWbemLocator.ConnectServer(Format('\\%s\root\CIMV2',[WbemComputer]), WbemUser, WbemPassword, WbemLocale,  WBEM_FLAG_CONNECT_USE_MAX_WAIT, '', nil, LWbemServices);


      if Succeeded(OpResult) then
      begin
        Writeln('Connected');
        try
          // Set security levels on a WMI connection
          if LocalConnection then
            if Failed(CoSetProxyBlanket(LWbemServices, RPC_C_AUTHN_WINNT, RPC_C_AUTHZ_NONE, nil, RPC_C_AUTHN_LEVEL_CALL, RPC_C_IMP_LEVEL_IMPERSONATE, nil, EOAC_NONE)) then Exit
             else
          else
            if Failed(CoSetProxyBlanket(LWbemServices, RPC_C_AUTHN_DEFAULT, RPC_C_AUTHZ_DEFAULT, PWideChar(Format('\\%s',[WbemComputer])), RPC_C_AUTHN_LEVEL_PKT_PRIVACY, RPC_C_IMP_LEVEL_IMPERSONATE, @AuthInfo, EOAC_NONE)) then Exit;

          if Succeeded(CoCreateInstance(CLSID_UnsecuredApartment, nil, CLSCTX_LOCAL_SERVER, IID_IUnsecuredApartment, LUnsecuredApartment)) then
          try
            Writeln('Running Wmi Query');
            OpResult := LWbemServices.ExecQuery('WQL', 'SELECT Name, ProcessId FROM Win32_Process', WBEM_FLAG_FORWARD_ONLY, nil, ppEnum);
            if Succeeded(OpResult) then
            begin
               // Set security for the enumerator proxy
               if not LocalConnection then
                if Failed(CoSetProxyBlanket(ppEnum, RPC_C_AUTHN_DEFAULT, RPC_C_AUTHZ_DEFAULT, PWideChar(Format('\\%s',[WbemComputer])), RPC_C_AUTHN_LEVEL_PKT_PRIVACY, RPC_C_IMP_LEVEL_IMPERSONATE, @AuthInfo, EOAC_NONE)) then Exit;

               while (ppEnum.Next(Integer(WBEM_INFINITE), 1, apObjects, puReturned)=0) do
               begin
                 pType:=nil;
                 plFlavor:=nil;

                 apObjects.Get('Name', 0, pVal, pType, plFlavor);// String
                 Writeln(Format('Name         %s',[String(pVal)]));//String
                 VarClear(pVal);

                 apObjects.Get('ProcessId', 0, pVal, pType, plFlavor);// Uint32
                 Writeln(Format('ProcessId    %d',[Integer(pVal)]));//Uint32
                 VarClear(pVal);
               end;
            end
            else
            if not GetExtendedErrorInfo(OpResult) then
            Writeln(Format('Error executing WQL sentence %x',[OpResult]));
          finally
            LUnsecuredApartment := nil;
          end;
        finally
          LWbemServices := nil;
        end;
      end
      else
        if not GetExtendedErrorInfo(OpResult) then
        Writeln(Format('Error Connecting to the Server %x',[OpResult]));
    finally
      LWbemLocator := nil;
    end;
  end
  else
   if not GetExtendedErrorInfo(OpResult) then
     Writeln(Format('Failed to create IWbemLocator object %x',[OpResult]));

end;


begin
 try
    if Succeeded(CoInitializeEx(nil, COINIT_MULTITHREADED)) then
    try
      TestWbem;
    finally
      CoUninitialize;
    end;
 except
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Writeln('Press Enter to exit');
 Readln;
end.


12 Comments

Implementing a Delphi for..in loop on COM collections and Variant Arrays

Enumerating a collection of Variants

Many times when you are working with COM objects you need iterate over a collection, and usually the way to do this is using the _NewEnum function (which return a IUnknown interface) implemented by the COM class and then assign that value to a IEnumVariant variable. something like this

var
 Enum   : IEnumVariant;
 iValue : LongWord;
begin
 oEnum    := IUnknown(ACollection._NewEnum) as IEnumVariant;
  while oEnum.Next(1, AItem, iValue) = S_OK do
  begin
    //do something 
         
  end;

This not look very complicated, but when do you have to work with many nested COM collections, the code turns more difficult to follow. Check this sample :

begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  wmiDiskDrives := FWMIService.ExecQuery('SELECT Caption, DeviceID FROM Win32_DiskDrive','WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(wmiDiskDrives._NewEnum) as IEnumVariant;//first enumerator
  while oEnum.Next(1, wmiDiskDrive, iValue) = 0 do
  begin
     DeviceID:=StringReplace(String(wmiDiskDrive.DeviceID),'\','\\',[rfReplaceAll]);
     wmiDiskPartitions := FWMIService.ExecQuery(Format('ASSOCIATORS OF {Win32_DiskDrive.DeviceID="%s"} WHERE AssocClass = Win32_DiskDriveToDiskPartition',[String(DeviceID)]),'WQL',wbemFlagForwardOnly);
     oEnum2          := IUnknown(wmiDiskPartitions._NewEnum) as IEnumVariant;//second enumerator
     while oEnum2.Next(1, wmiDiskPartition, iValue) = 0 do
     begin
        wmiLogicalDisks := FWMIService.ExecQuery(Format('ASSOCIATORS OF {Win32_DiskPartition.DeviceID="%s"} WHERE AssocClass = Win32_LogicalDiskToPartition',[String(wmiDiskPartition.DeviceID)]),'WQL',wbemFlagForwardOnly);
        oEnum3          := IUnknown(wmiLogicalDisks._NewEnum) as IEnumVariant;//third enumerator
        while oEnum3.Next(1, wmiLogicalDisk, iValue) = 0 do
        begin
          Writeln(Format('Drive letter associated with disk drive  %s %s Partition %s is %s',[String(wmiDiskDrive.Caption),String(wmiDiskDrive.DeviceID),String(wmiDiskPartition.DeviceID),String(wmiLogicalDisk.DeviceID)]));
          wmiLogicalDisk:=Unassigned;
        end;
       wmiDiskPartition:=Unassigned;
     end;
    wmiDiskDrive:=Unassigned;
    Writeln;
  end;
end;

Now look the same code using a for in loop in vbscript, which looks much more easy to follow and understeand

ComputerName = "."
Set wmiServices  = GetObject ("winmgmts:{impersonationLevel=Impersonate}!//" & ComputerName)
Set wmiDiskDrives =  wmiServices.ExecQuery("SELECT Caption, DeviceID FROM Win32_DiskDrive")

For Each wmiDiskDrive In wmiDiskDrives
    WScript.Echo "Disk drive Caption: " & wmiDiskDrive.Caption & VbNewLine & "DeviceID: " & " (" & wmiDiskDrive.DeviceID & ")"
    query = "ASSOCIATORS OF {Win32_DiskDrive.DeviceID='"  & wmiDiskDrive.DeviceID & "'} WHERE AssocClass = Win32_DiskDriveToDiskPartition"    
    Set wmiDiskPartitions = wmiServices.ExecQuery(query)
    For Each wmiDiskPartition In wmiDiskPartition
        Set wmiLogicalDisks = wmiServices.ExecQuery ("ASSOCIATORS OF {Win32_DiskPartition.DeviceID='" & wmiDiskPartition.DeviceID & "'} WHERE AssocClass = Win32_LogicalDiskToPartition") 
        For Each wmiLogicalDisk In wmiLogicalDisks
            WScript.Echo "Drive letter associated with disk drive = " & wmiDiskDrive.Caption & wmiDiskDrive.DeviceID & VbNewLine & " Partition = " & wmiDiskPartition.DeviceID & VbNewLine & " is " & wmiLogicalDisk.DeviceID
        Next      
    Next
Next

Now look back again the delphi code using for..in loop for iterate over the COM collection

begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  wmiDiskDrives := FWMIService.ExecQuery('SELECT Caption, DeviceID FROM Win32_DiskDrive','WQL',wbemFlagForwardOnly);
  for wmiDiskDrive in GetOleVariantEnum(wmiDiskDrives) do
  begin
     DeviceID:=StringReplace(String(wmiDiskDrive.DeviceID),'\','\\',[rfReplaceAll]);
     wmiDiskPartitions := FWMIService.ExecQuery(Format('ASSOCIATORS OF {Win32_DiskDrive.DeviceID="%s"} WHERE AssocClass = Win32_DiskDriveToDiskPartition',[String(DeviceID)]),'WQL',wbemFlagForwardOnly);
     for wmiDiskPartition in GetOleVariantEnum(wmiDiskPartitions) do
     begin
        wmiLogicalDisks := FWMIService.ExecQuery(Format('ASSOCIATORS OF {Win32_DiskPartition.DeviceID="%s"} WHERE AssocClass = Win32_LogicalDiskToPartition',[String(wmiDiskPartition.DeviceID)]),'WQL',wbemFlagForwardOnly);
        for wmiLogicalDisk in GetOleVariantEnum(wmiLogicalDisks)  do
          Writeln(Format('Drive letter associated with disk drive  %s %s Partition %s is %s',[String(wmiDiskDrive.Caption),String(wmiDiskDrive.DeviceID),String(wmiDiskPartition.DeviceID),String(wmiLogicalDisk.DeviceID)]));
     end;
    Writeln;
  end;
end;

The delphi code now looks more cleaner and easy to follow. Now you are wondering how this was made? the answer is writting a class with an enumerator and a function which returns an interface with the implemented enumerator.

check how the class looks

type
  IOleVariantEnum  = interface
    function  GetCurrent: OLEVariant;
    function  MoveNext: Boolean;
    property  Current: OLEVariant read GetCurrent;
  end;

  IGetOleVariantEnum = interface
    function GetEnumerator: IOleVariantEnum;
  end;

  TOleVariantEnum = class(TInterfacedObject, IOleVariantEnum, IGetOleVariantEnum)
  private
    FCurrent : OLEVariant;
    FEnum    : IEnumVARIANT;
  public
    function GetEnumerator: IOleVariantEnum;
    constructor Create(Collection: OLEVariant);
    function  GetCurrent: OLEVariant;
    function  MoveNext: Boolean;
    property  Current: OLEVariant read GetCurrent;
  end;

As you see we have a base interface (IOleVariantEnum) with the methods to implement a enumerator, another interface (IGetOleVariantEnum) which return a enumerator and finally a class which descend from both interfaces and implements the logic of the enumerator.

The implementation of the last class is very simple and uses the IEnumVARIANT interface to iterate over the collection and return the current item.

constructor TOleVariantEnum.Create(Collection: OLEVariant);
begin
  inherited Create;
  FEnum := IUnknown(Collection._NewEnum) As IEnumVARIANT; //Set the COM enumerator for the variants collection
end;

function TOleVariantEnum.MoveNext: Boolean;
var
  iValue        : LongWord;
begin
  FCurrent:=Unassigned;//clear the previous value stored in FCurrent avoiding memory leaks
  Result:= FEnum.Next(1, FCurrent, iValue) = S_OK; //Get the next item in the collection into FCurrent
end;

function TOleVariantEnum.GetCurrent: OLEVariant;
begin
  Result:=FCurrent;
end;

function TOleVariantEnum.GetEnumerator: IOleVariantEnum;
begin
  Result:=Self;
end;

And now finally the function which makes the magic

function GetOleVariantEnum(Collection:OleVariant):IGetOleVariantEnum;
begin
 Result := TOleVariantEnum.Create(Collection);
end;

Now the good part of this is which you don’t need to worry of release the value returned by the GetOleVariantEnum function.

Finally you can rewrite your code using the TOleVariantEnum class

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: TOleVariantEnum;
  FWbemObject   : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= TOleVariantEnum.Create(FWMIService.ExecQuery('SELECT ProcessId FROM Win32_Process','WQL',wbemFlagForwardOnly));
  try
    for FWbemObject in FWbemObjectSet do
      Writeln(Format('Pid %d',[Integer(FWbemObject.ProcessId)]));
  finally
    FWbemObjectSet:=nil;
  end;
end;

or simply using the GetOleVariantEnum function.

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObjectSet:= FWMIService.ExecQuery('SELECT ProcessId FROM Win32_Process','WQL',wbemFlagForwardOnly);
  for FWbemObject in GetOleVariantEnum(FWbemObjectSet) do
    Writeln(Format('Pid %d',[Integer(FWbemObject.ProcessId)]));
end;

Enumerating a Variant Array

Tipically when you need iterate over a Variant Array you must get the bounds of the array using the VarArrayLowBound and VarArrayHighBound functions and from there you can access every item in the array only using the [] notation.

    for i := VarArrayLowBound(AvarArray, 1) to VarArrayHighBound(AvarArray, 1) do
     Item:=AvarArray[i];

Now using the same base interfaces you can implement a class to get a enumerator for this kind of arrays.

  TOleVariantArrayEnum = class(TInterfacedObject, IOleVariantEnum, IGetOleVariantEnum)
  private
    FCollection : OLEVariant;
    FIndex      : Integer;
    FLowBound   : Integer;
    FHighBound  : Integer;
  public
    function GetEnumerator: IOleVariantEnum;
    constructor Create(Collection: OLEVariant);
    function  GetCurrent: OLEVariant;
    function  MoveNext: Boolean;
    property  Current: OLEVariant read GetCurrent;
  end;

and the implementation

constructor TOleVariantArrayEnum.Create(Collection: OLEVariant);
begin
  inherited Create;
  FCollection:=Collection;
  FLowBound :=VarArrayLowBound(FCollection, 1);
  FHighBound:=VarArrayHighBound(FCollection, 1);
  FIndex:=FLowBound-1;
end;

function TOleVariantArrayEnum.GetCurrent: OLEVariant;
begin
  Result:=FCollection[FIndex];
end;

function TOleVariantArrayEnum.GetEnumerator: IOleVariantEnum;
begin
  Result:=Self;
end;

function TOleVariantArrayEnum.MoveNext: Boolean;
begin
  Result := FIndex < FHighBound;
  if Result then
    Inc(FIndex);
end;

and the helper function

function GetOleVariantArrEnum(Collection:OleVariant):IGetOleVariantEnum;
begin
 Result := TOleVariantArrayEnum.Create(Collection);
end;

And now you can iterate over the array using a for..in loop

  for Item in GetOleVariantArrEnum(AvarArray) do       

you can get the full source code of these classes and interfaces here.


7 Comments

Using Delphi and ADSI to enumerate local and remote shared resources

One of the most rich Directory Access Technologies of Microsoft is the Active Directory Service Interfaces (ADSI) which is a set of interfaces designed to access the features of directory services from different network providers, in this case we will use the WinNT Provider to access the shared resources of a local or remote machine.  The aim of this post is show you how you can obtain the information related to the shared resources from a Delphi application.

Getting the interfaces

The common way to access the ADSI Interfaces from Delphi is importing the Active DS type library.

After of import the type library you will got a large unit file with many interfaces , constants and types which we will not need in this case, and only increase the final size of our application. So we can extract the interfaces for access the network shared resources (see the next source that shows the interfaces to the task)

const
  IID_IADsContainer: TGUID = '{001677D0-FD16-11CE-ABC4-02608C9E7553}';
  IID_IADsFileServiceOperations: TGUID = '{A02DED10-31CA-11CF-A98A-00AA006BC149}';
  ADS_SECURE_AUTHENTICATION = $00000001;
type
  IADsCollection = interface(IDispatch)
    ['{72B945E0-253B-11CF-A988-00AA006BC149}']
    function Get__NewEnum: IUnknown; safecall;
    procedure Add(const bstrName: WideString; vItem: OleVariant); safecall;
    procedure Remove(const bstrItemToBeRemoved: WideString); safecall;
    function GetObject(const bstrName: WideString): OleVariant; safecall;
    property _NewEnum: IUnknown read Get__NewEnum;
  end;

  IADs = interface(IDispatch)
    ['{FD8256D0-FD15-11CE-ABC4-02608C9E7553}']
    function Get_Name: WideString; safecall;
    function Get_Class_: WideString; safecall;
    function Get_GUID: WideString; safecall;
    function Get_ADsPath: WideString; safecall;
    function Get_Parent: WideString; safecall;
    function Get_Schema: WideString; safecall;
    procedure GetInfo; safecall;
    procedure SetInfo; safecall;
    function Get(const bstrName: WideString): OleVariant; safecall;
    procedure Put(const bstrName: WideString; vProp: OleVariant); safecall;
    function GetEx(const bstrName: WideString): OleVariant; safecall;
    procedure PutEx(lnControlCode: Integer; const bstrName: WideString; vProp: OleVariant); safecall;
    procedure GetInfoEx(vProperties: OleVariant; lnReserved: Integer); safecall;
    property Name: WideString read Get_Name;
    property Class_: WideString read Get_Class_;
    property GUID: WideString read Get_GUID;
    property ADsPath: WideString read Get_ADsPath;
    property Parent: WideString read Get_Parent;
    property Schema: WideString read Get_Schema;
  end;

  IADsContainer = interface(IDispatch)
    ['{001677D0-FD16-11CE-ABC4-02608C9E7553}']
    function Get_Count: Integer; safecall;
    function Get__NewEnum: IUnknown; safecall;
    function Get_Filter: OleVariant; safecall;
    procedure Set_Filter(pVar: OleVariant); safecall;
    function Get_Hints: OleVariant; safecall;
    procedure Set_Hints(pvFilter: OleVariant); safecall;
    function GetObject(const ClassName: WideString; const RelativeName: WideString): IDispatch; safecall;
    function Create(const ClassName: WideString; const RelativeName: WideString): IDispatch; safecall;
    procedure Delete(const bstrClassName: WideString; const bstrRelativeName: WideString); safecall;
    function CopyHere(const SourceName: WideString; const NewName: WideString): IDispatch; safecall;
    function MoveHere(const SourceName: WideString; const NewName: WideString): IDispatch; safecall;
    property Count: Integer read Get_Count;
    property _NewEnum: IUnknown read Get__NewEnum;
    property Filter: OleVariant read Get_Filter write Set_Filter;
    property Hints: OleVariant read Get_Hints write Set_Hints;
  end;

  IADsServiceOperations = interface(IADs)
    ['{5D7B33F0-31CA-11CF-A98A-00AA006BC149}']
    function Get_Status: Integer; safecall;
    procedure Start; safecall;
    procedure Stop; safecall;
    procedure Pause; safecall;
    procedure Continue; safecall;
    procedure SetPassword(const bstrNewPassword: WideString); safecall;
    property Status: Integer read Get_Status;
  end;

  IADsFileServiceOperations = interface(IADsServiceOperations)
    ['{A02DED10-31CA-11CF-A98A-00AA006BC149}']
    function Sessions: IADsCollection; safecall;
    function Resources: IADsCollection; safecall;
  end;

  IADsResource = interface(IADs)
    ['{34A05B20-4AAB-11CF-AE2C-00AA006EBFB9}']
    function Get_User: WideString; safecall;
    function Get_UserPath: WideString; safecall;
    function Get_Path: WideString; safecall;
    function Get_LockCount: Integer; safecall;
    property User: WideString read Get_User;
    property UserPath: WideString read Get_UserPath;
    property Path: WideString read Get_Path;
    property LockCount: Integer read Get_LockCount;
  end;

  IADsSession = interface(IADs)
    ['{398B7DA0-4AAB-11CF-AE2C-00AA006EBFB9}']
    function Get_User: WideString; safecall;
    function Get_UserPath: WideString; safecall;
    function Get_Computer: WideString; safecall;
    function Get_ComputerPath: WideString; safecall;
    function Get_ConnectTime: Integer; safecall;
    function Get_IdleTime: Integer; safecall;
    property User: WideString read Get_User;
    property UserPath: WideString read Get_UserPath;
    property Computer: WideString read Get_Computer;
    property ComputerPath: WideString read Get_ComputerPath;
    property ConnectTime: Integer read Get_ConnectTime;
    property IdleTime: Integer read Get_IdleTime;
  end;

  IADsFileShare = interface(IADs)
    ['{EB6DCAF0-4B83-11CF-A995-00AA006BC149}']
    function Get_CurrentUserCount: Integer; safecall;
    function Get_Description: WideString; safecall;
    procedure Set_Description(const retval: WideString); safecall;
    function Get_HostComputer: WideString; safecall;
    procedure Set_HostComputer(const retval: WideString); safecall;
    function Get_Path: WideString; safecall;
    procedure Set_Path(const retval: WideString); safecall;
    function Get_MaxUserCount: Integer; safecall;
    procedure Set_MaxUserCount(retval: Integer); safecall;
    property CurrentUserCount: Integer read Get_CurrentUserCount;
    property Description: WideString read Get_Description write Set_Description;
    property HostComputer: WideString read Get_HostComputer write Set_HostComputer;
    property Path: WideString read Get_Path write Set_Path;
    property MaxUserCount: Integer read Get_MaxUserCount write Set_MaxUserCount;
  end;

In addition to the interfaces we need the ADsOpenObject function which allow you binds to an ADSI interface.

check the syntax of this function

HRESULT ADsOpenObject(
  __in   LPCWSTR lpszPathName,
  __in   LPCWSTR lpszUserName,
  __in   LPCWSTR lpszPassword,
  __in   DWORD dwReserved,
  __in   REFIID riid,
  __out  VOID **ppObject
);

The Delphi equivalent can be

function ADsOpenObject(lpszPathName,lpszUserName,lpszPassword : WideString;
dwReserved : DWORD; const riid:TGUID; out ppObject): HResult; safecall; external 'activeds.dll';

or

function ADsOpenObject(lpszPathName,lpszUserName,lpszPassword : WideString;
dwReserved : DWORD; const riid:TGUID; out ppObject): HResult; stdcall; external 'activeds.dll';

As you can see the only difference is the calling convention (safecall vs stdcall), if you want which Delphi check the value of the returned HResult and raises the exception for you then use the safecall calling convention else if you want check manually the HResult returned by the function use stdcall

Listing the Connected Sessions

To list the Open Sessions (Machines connected) to the shared resources we must use the IADsFileServiceOperations interface and the Sessions function which return a collection of the open sessions for the service.

const
   lpszUserName ='';  // set the user name used to establish the connection to the remote machine
   lpszPassword ='';  // set the password used to establish the connection to the remote machine
   lpszComputer ='.'; // the "." is for the local machine, you can set the name of the remote machine
var
  FSO             : IADsFileServiceOperations;
  Sessions        : IADsCollection;
  Session         : IADsSession;
  rgvar           : OleVariant;
  pceltFetched    : Cardinal;
  oEnum           : IEnumvariant;
  dt              : TDateTime;
begin
  //connect to the file service of the loal o remote machine
  OleCheck(ADsOpenObject(Format('WinNT://%s/LanmanServer',[lpszComputer]), lpszUserName, lpszPassword, ADS_SECURE_AUTHENTICATION,IID_IADsFileServiceOperations,FSO));
  //obtain the sessions
  Sessions := FSO.Sessions;
  //Get the enumerator
  oEnum:= IUnknown(Sessions._NewEnum) as IEnumVariant;
  while oEnum.Next(1, rgvar, pceltFetched) = 0 do
  begin
    //cast the current element to IADsSession
    Session:=IUnknown(rgvar) as IADsSession;
    try
      Writeln('Computer        '+Session.Computer);
      dt := Session.ConnectTime / SecsPerDay; // the ConnectTime  property return the value in seconds
      Writeln('Connected Time  '+FormatDateTime('hh:nn:ss',dt));
      dt := Session.IdleTime / SecsPerDay; // the IdleTime property return the value in seconds
      Writeln('Idle Time       '+FormatDateTime('hh:nn:ss',dt));
      Writeln('Name            '+Session.Name);
      Writeln('User            '+Session.User);
      Writeln('');
    finally
      rgvar:=Unassigned; //clear the variant used for hold the values avoiding meory leaks
    end;
  end;
end;

With this simple code you will get the same information returned by the Windows option Computer Management -> System Tools -> Shared folders > Sessions

Listing the shared resources in use (opened)

To List the opened resources like folders and files we must use the IADsFileServiceOperations interface and the Resources function which return a collection of the open resources for the service.

procedure ListSharedResourcesInUse;
const
   lpszUserName ='';
   lpszPassword ='';
   lpszComputer ='.';
var
  FSO             : IADsFileServiceOperations;
  Resources       : IADsCollection;
  Resource        : IADsResource;
  rgvar           : OleVariant;
  pceltFetched    : Cardinal;
  oEnum           : IEnumvariant;
begin
  //connect to the WinNt provider of the local or remote machine and get an instance to the file service
  OleCheck(ADsOpenObject(Format('WinNT://%s/LanmanServer',[lpszComputer]), lpszUserName, lpszPassword, ADS_SECURE_AUTHENTICATION,IID_IADsFileServiceOperations,FSO));
  //Get the opened resources
  Resources := FSO.Resources;
  //get the enumerator
  oEnum:= IUnknown(Resources._NewEnum) as IEnumVariant;
  while oEnum.Next(1, rgvar, pceltFetched) = 0 do
  begin
    //cast the current element of the collection to the IADsResource interface
    Resource:=IUnknown(rgvar) as IADsResource;
    try
      try
       Writeln(Format('Resource %s User %s LockCount %d',[Resource.Path, Resource.User, Resource.LockCount]));
      except
        on E:EOleException  do
        if E.ErrorCode<> HResult($80070002) then  //in some cases this exception (path not found) is raised when you enumerate the opened resources, you can ignore without problems
         raise;
      end;
    finally
      rgvar:=Unassigned; //avoid a memory leak
    end;
  end;
end;

With this code you will get the same information returned by the Windows option Computer Management -> System Tools -> Shared folders > Open files

Listing the Shared Resources

Finally to List the shared resources we must connect to the local or remote machine using the ADsOpenObject function passing a IADsContainer interface which return a collection with the resources.

procedure ListShared;
const
   lpszUserName ='';
   lpszPassword ='';
   lpszComputer ='.';
var
  Shares          : IADsContainer;
  Share           : IADsFileShare;
  rgvar           : OleVariant;
  pceltFetched    : Cardinal;
  oEnum           : IEnumvariant;
begin
  //connect to the network provider and get the collection of shared resources
  OleCheck(ADsOpenObject(Format('WinNT://%s/LanmanServer',[lpszComputer]), lpszUserName, lpszPassword, ADS_SECURE_AUTHENTICATION,IID_IADsContainer,Shares));
  //get the enumerator
  oEnum:= IUnknown(Shares._NewEnum) as IEnumVariant;
  while oEnum.Next(1, rgvar, pceltFetched) = 0 do
  begin
    //cast the current element to IADsFileShare
    Share:=IUnknown(rgvar) as IADsFileShare;
    try
      Writeln('CurrentUserCount '+IntToStr(Share.CurrentUserCount));
      Writeln('Host Computer    '+Share.HostComputer);
      Writeln('Description      '+Share.Description);
      Writeln('Path             '+Share.Path);
      Writeln('Max User Count   '+IntToStr(Share.MaxUserCount));
      Writeln('');
    finally
     rgvar:=Unassigned; //avoid memory leaks
    end;
  end;
end;

The Console application

This is the full source code of a console application to show all the tasks described in this post.

{$APPTYPE CONSOLE}
{.$DEFINE USE_ActiveDs_TLB}

uses
  {$IFDEF USE_ActiveDs_TLB}
  ActiveDs_TLB,
  {$ENDIF}
  Windows,
  ComObj,
  Variants,
  ActiveX,
  SysUtils;

{$IFNDEF USE_ActiveDs_TLB}
const
  IID_IADsContainer: TGUID = '{001677D0-FD16-11CE-ABC4-02608C9E7553}';
  IID_IADsFileServiceOperations: TGUID = '{A02DED10-31CA-11CF-A98A-00AA006BC149}';
  ADS_SECURE_AUTHENTICATION = $00000001;
type
  IADsCollection = interface(IDispatch)
    ['{72B945E0-253B-11CF-A988-00AA006BC149}']
    function Get__NewEnum: IUnknown; safecall;
    procedure Add(const bstrName: WideString; vItem: OleVariant); safecall;
    procedure Remove(const bstrItemToBeRemoved: WideString); safecall;
    function GetObject(const bstrName: WideString): OleVariant; safecall;
    property _NewEnum: IUnknown read Get__NewEnum;
  end;

  IADs = interface(IDispatch)
    ['{FD8256D0-FD15-11CE-ABC4-02608C9E7553}']
    function Get_Name: WideString; safecall;
    function Get_Class_: WideString; safecall;
    function Get_GUID: WideString; safecall;
    function Get_ADsPath: WideString; safecall;
    function Get_Parent: WideString; safecall;
    function Get_Schema: WideString; safecall;
    procedure GetInfo; safecall;
    procedure SetInfo; safecall;
    function Get(const bstrName: WideString): OleVariant; safecall;
    procedure Put(const bstrName: WideString; vProp: OleVariant); safecall;
    function GetEx(const bstrName: WideString): OleVariant; safecall;
    procedure PutEx(lnControlCode: Integer; const bstrName: WideString; vProp: OleVariant); safecall;
    procedure GetInfoEx(vProperties: OleVariant; lnReserved: Integer); safecall;
    property Name: WideString read Get_Name;
    property Class_: WideString read Get_Class_;
    property GUID: WideString read Get_GUID;
    property ADsPath: WideString read Get_ADsPath;
    property Parent: WideString read Get_Parent;
    property Schema: WideString read Get_Schema;
  end;

  IADsContainer = interface(IDispatch)
    ['{001677D0-FD16-11CE-ABC4-02608C9E7553}']
    function Get_Count: Integer; safecall;
    function Get__NewEnum: IUnknown; safecall;
    function Get_Filter: OleVariant; safecall;
    procedure Set_Filter(pVar: OleVariant); safecall;
    function Get_Hints: OleVariant; safecall;
    procedure Set_Hints(pvFilter: OleVariant); safecall;
    function GetObject(const ClassName: WideString; const RelativeName: WideString): IDispatch; safecall;
    function Create(const ClassName: WideString; const RelativeName: WideString): IDispatch; safecall;
    procedure Delete(const bstrClassName: WideString; const bstrRelativeName: WideString); safecall;
    function CopyHere(const SourceName: WideString; const NewName: WideString): IDispatch; safecall;
    function MoveHere(const SourceName: WideString; const NewName: WideString): IDispatch; safecall;
    property Count: Integer read Get_Count;
    property _NewEnum: IUnknown read Get__NewEnum;
    property Filter: OleVariant read Get_Filter write Set_Filter;
    property Hints: OleVariant read Get_Hints write Set_Hints;
  end;

  IADsServiceOperations = interface(IADs)
    ['{5D7B33F0-31CA-11CF-A98A-00AA006BC149}']
    function Get_Status: Integer; safecall;
    procedure Start; safecall;
    procedure Stop; safecall;
    procedure Pause; safecall;
    procedure Continue; safecall;
    procedure SetPassword(const bstrNewPassword: WideString); safecall;
    property Status: Integer read Get_Status;
  end;

  IADsFileServiceOperations = interface(IADsServiceOperations)
    ['{A02DED10-31CA-11CF-A98A-00AA006BC149}']
    function Sessions: IADsCollection; safecall;
    function Resources: IADsCollection; safecall;
  end;

  IADsResource = interface(IADs)
    ['{34A05B20-4AAB-11CF-AE2C-00AA006EBFB9}']
    function Get_User: WideString; safecall;
    function Get_UserPath: WideString; safecall;
    function Get_Path: WideString; safecall;
    function Get_LockCount: Integer; safecall;
    property User: WideString read Get_User;
    property UserPath: WideString read Get_UserPath;
    property Path: WideString read Get_Path;
    property LockCount: Integer read Get_LockCount;
  end;

  IADsSession = interface(IADs)
    ['{398B7DA0-4AAB-11CF-AE2C-00AA006EBFB9}']
    function Get_User: WideString; safecall;
    function Get_UserPath: WideString; safecall;
    function Get_Computer: WideString; safecall;
    function Get_ComputerPath: WideString; safecall;
    function Get_ConnectTime: Integer; safecall;
    function Get_IdleTime: Integer; safecall;
    property User: WideString read Get_User;
    property UserPath: WideString read Get_UserPath;
    property Computer: WideString read Get_Computer;
    property ComputerPath: WideString read Get_ComputerPath;
    property ConnectTime: Integer read Get_ConnectTime;
    property IdleTime: Integer read Get_IdleTime;
  end;

  IADsFileShare = interface(IADs)
    ['{EB6DCAF0-4B83-11CF-A995-00AA006BC149}']
    function Get_CurrentUserCount: Integer; safecall;
    function Get_Description: WideString; safecall;
    procedure Set_Description(const retval: WideString); safecall;
    function Get_HostComputer: WideString; safecall;
    procedure Set_HostComputer(const retval: WideString); safecall;
    function Get_Path: WideString; safecall;
    procedure Set_Path(const retval: WideString); safecall;
    function Get_MaxUserCount: Integer; safecall;
    procedure Set_MaxUserCount(retval: Integer); safecall;
    property CurrentUserCount: Integer read Get_CurrentUserCount;
    property Description: WideString read Get_Description write Set_Description;
    property HostComputer: WideString read Get_HostComputer write Set_HostComputer;
    property Path: WideString read Get_Path write Set_Path;
    property MaxUserCount: Integer read Get_MaxUserCount write Set_MaxUserCount;
  end;
{$ENDIF}

function ADsOpenObject(lpszPathName,lpszUserName,lpszPassword : WideString;dwReserved : DWORD; const riid:TGUID; out ppObject): HResult; stdcall; external 'activeds.dll';

procedure ListConnectedSessions;
const
   lpszUserName ='';
   lpszPassword ='';
   lpszComputer ='.';
var
  FSO             : IADsFileServiceOperations;
  Sessions        : IADsCollection;
  Session         : IADsSession;
  rgvar           : OleVariant;
  pceltFetched    : Cardinal;
  oEnum           : IEnumvariant;
  dt              : TDateTime;
begin
  OleCheck(ADsOpenObject(Format('WinNT://%s/LanmanServer',[lpszComputer]), lpszUserName, lpszPassword, ADS_SECURE_AUTHENTICATION,IID_IADsFileServiceOperations,FSO));
  Sessions := FSO.Sessions;
  oEnum:= IUnknown(Sessions._NewEnum) as IEnumVariant;
  while oEnum.Next(1, rgvar, pceltFetched) = 0 do
  begin
    Session:=IUnknown(rgvar) as IADsSession;
    try
      Writeln('Computer        '+Session.Computer);
      dt := Session.ConnectTime / SecsPerDay;
      Writeln('Connected Time  '+FormatDateTime('hh:nn:ss',dt));
      dt := Session.IdleTime / SecsPerDay;
      Writeln('Idle Time       '+FormatDateTime('hh:nn:ss',dt));
      Writeln('Name            '+Session.Name);
      Writeln('User            '+Session.User);
      Writeln('');
    finally
      rgvar:=Unassigned;
    end;
  end;
end;

procedure ListSharedResourcesInUse;
const
   lpszUserName ='';
   lpszPassword ='';
   lpszComputer ='.';
var
  FSO             : IADsFileServiceOperations;
  Resources       : IADsCollection;
  Resource        : IADsResource;
  rgvar           : OleVariant;
  pceltFetched    : Cardinal;
  oEnum           : IEnumvariant;
begin
  OleCheck(ADsOpenObject(Format('WinNT://%s/LanmanServer',[lpszComputer]), lpszUserName, lpszPassword, ADS_SECURE_AUTHENTICATION,IID_IADsFileServiceOperations,FSO));
  Resources := FSO.Resources;
  oEnum:= IUnknown(Resources._NewEnum) as IEnumVariant;
  while oEnum.Next(1, rgvar, pceltFetched) = 0 do
  begin
    Resource:=IUnknown(rgvar) as IADsResource;
    try
      try
       Writeln(Format('Resource %s User %s LockCount %d',[Resource.Path, Resource.User, Resource.LockCount]));
      except
        on E:EOleException  do
        if E.ErrorCode<> HResult($80070002) then  //ignore path not found exception
         raise;
      end;
    finally
      rgvar:=Unassigned;
    end;

  end;
end;

procedure ListShared;
const
   lpszUserName ='';
   lpszPassword ='';
   lpszComputer ='.';
var
  Shares          : IADsContainer;
  Share           : IADsFileShare;
  rgvar           : OleVariant;
  pceltFetched    : Cardinal;
  oEnum           : IEnumvariant;
begin
  OleCheck(ADsOpenObject(Format('WinNT://%s/LanmanServer',[lpszComputer]), lpszUserName, lpszPassword, ADS_SECURE_AUTHENTICATION,IID_IADsContainer,Shares));
  oEnum:= IUnknown(Shares._NewEnum) as IEnumVariant;
  while oEnum.Next(1, rgvar, pceltFetched) = 0 do
  begin
    Share:=IUnknown(rgvar) as IADsFileShare;
    try
      Writeln('CurrentUserCount '+IntToStr(Share.CurrentUserCount));
      Writeln('Host Computer    '+Share.HostComputer);
      Writeln('Description      '+Share.Description);
      Writeln('Path             '+Share.Path);
      Writeln('Max User Count   '+IntToStr(Share.MaxUserCount));
      Writeln('');
    finally
     rgvar:=Unassigned;
    end;
  end;
end;

begin
 try
    CoInitialize(nil);
    try
      ListSharedResourcesInUse;
      ListConnectedSessions;
      ListShared;
    finally
      CoUninitialize;
    end;
 except
    on E:EOleException  do
        Writeln(Format('EOleException %s Code %x',[E.Message,E.ErrorCode]));
    on E:EOleSysError  do
        Writeln(Format('EOleSysError  %s Code %x',[E.Message,E.ErrorCode]));
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Writeln('Press Enter to exit');
 Readln;
end.