The Road to Delphi

Delphi – Free Pascal – Oxygene


Leave a comment

How distinguish when Windows was installed in Legacy BIOS or UEFI mode using Delphi?

As part of the TSMBIOS project, I needed a method to distinguish when Windows was installed in Legacy BIOS or UEFI mode. The solution was provided by the GetFirmwareEnvironmentVariable function.

The msdn documentation states

Firmware variables are not supported on a legacy BIOS-based system. The GetFirmwareEnvironmentVariable function will always fail on a legacy BIOS-based system, or if Windows was installed using legacy BIOS on a system that supports both legacy BIOS and UEFI. To identify these conditions, call the function with a dummy firmware environment name such as an empty string (“”) for the lpName parameter and a dummy GUID such as “{00000000-0000-0000-0000-000000000000}” for the lpGuid parameter. On a legacy BIOS-based system, or on a system that supports both legacy BIOS and UEFI where Windows was installed using legacy BIOS, the function will fail with ERROR_INVALID_FUNCTION. On a UEFI-based system, the function will fail with an error specific to the firmware, such as ERROR_NOACCESS, to indicate that the dummy GUID namespace does not exist.
.

So the Delphi code to detect such condition will be something like so

{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils;

function GetFirmwareEnvironmentVariableA(lpName, lpGuid: LPCSTR; pBuffer: Pointer;
  nSize: DWORD): DWORD; stdcall; external kernel32 name 'GetFirmwareEnvironmentVariableA';

begin
  try
    GetFirmwareEnvironmentVariableA('','{00000000-0000-0000-0000-000000000000}', nil,0);
    if (GetLastError = ERROR_INVALID_FUNCTION) then
      Writeln('Legacy BIOS')
    else
      Writeln('UEFI Boot Mode');
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.


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.


4 Comments

Getting the environment variables of an external x86 and x64 process

On my last post was show how get the environment variables of an external x86 process, now it’s time to show how access the same information for x64 (and x86) process from a 64 bits application.

In order to access the environment variables of a x64 process, you must use a 64 bits application, So if you compile the code posted in the last article in a 64 bits app, the code will still working but only for read the environment variables of x64 processes, this is because the offset of the fields of the records changes due to the Pointer and THandle types now have a 8 bytes size, and the structures which hold the data in a 32 bits process still using 4 bytes to represent the adresses (Pointers) and Handles (THandle). So the first step is create 2 new types to replace the Pointer and THandle types like so.

  Pointer32 = ULONG;
  THANDLE32 = ULONG;

Now using these new types we can create a 32 bits version of the records to access the PEB.

type
  Pointer32 = ULONG;
  THANDLE32 = ULONG;

  _UNICODE_STRING32 = record
    Length: Word;
    MaximumLength: Word;
    Buffer: Pointer32;
  end;
  UNICODE_STRING32 = _UNICODE_STRING32;

  _RTL_DRIVE_LETTER_CURDIR32 = record
    Flags: Word;
    Length: Word;
    TimeStamp: ULONG;
    DosPath: UNICODE_STRING32;
  end;
  RTL_DRIVE_LETTER_CURDIR32 = _RTL_DRIVE_LETTER_CURDIR32;

   _CURDIR32 = record
    DosPath: UNICODE_STRING32;
    Handle: THANDLE32;
  end;
  CURDIR32 = _CURDIR32;

  _RTL_USER_PROCESS_PARAMETERS32 = record
    MaximumLength: ULONG;
    Length: ULONG;
    Flags: ULONG;
    DebugFlags: ULONG;
    ConsoleHandle: THANDLE32;
    ConsoleFlags: ULONG;
    StandardInput: THANDLE32;
    StandardOutput: THANDLE32;
    StandardError: THANDLE32;
    CurrentDirectory: CURDIR32;
    DllPath: UNICODE_STRING32;
    ImagePathName: UNICODE_STRING32;
    CommandLine: UNICODE_STRING32;
    Environment: Pointer32;
    StartingX: ULONG;
    StartingY: ULONG;
    CountX: ULONG;
    CountY: ULONG;
    CountCharsX: ULONG;
    CountCharsY: ULONG;
    FillAttribute: ULONG;
    WindowFlags: ULONG;
    ShowWindowFlags: ULONG;
    WindowTitle: UNICODE_STRING32;
    DesktopInfo: UNICODE_STRING32;
    ShellInfo: UNICODE_STRING32;
    RuntimeData: UNICODE_STRING32;
    CurrentDirectories: array[0..31] of RTL_DRIVE_LETTER_CURDIR32;
  end;
  RTL_USER_PROCESS_PARAMETERS32 = _RTL_USER_PROCESS_PARAMETERS32;
  PRTL_USER_PROCESS_PARAMETERS32 = ^RTL_USER_PROCESS_PARAMETERS32;

  _PEB32 = record
    Reserved1     : array [0..1] of Byte;
    BeingDebugged : Byte;
    Reserved2     : Byte;
    Reserved3     : array [0..1] of Pointer32;
    Ldr           : Pointer32;
    ProcessParameters : Pointer32;//PRTL_USER_PROCESS_PARAMETERS;
    Reserved4     : array [0..102] of Byte;
    Reserved5     : array [0..51] of Pointer32;
    PostProcessInitRoutine : Pointer32;
    Reserved6     : array [0..127] of byte;
    Reserved7     : Pointer32;
    SessionId     : ULONG;
  end;
   PEB32=_PEB32;

Reading the PEB Address of a X86 process from a 64 bits app

Additional to the above changes we must modify the code to get the PEB address of a 32 bits process, this can be done using the NtQueryInformationProcess function passing ProcessWow64Information value, this will return the PEB Adresss of a process running under WOW64.

  NtQueryInformationProcess(ProcessHandle, ProcessWow64Information, @PEBBaseAddress32, SizeOf(PEBBaseAddress32), nil)

And now using the ReadProcessMemory function and the new defined types we can read the environment variables block.

  //read the PEB structure
  if not ReadProcessMemory(ProcessHandle, PEBBaseAddress32, @Peb32, sizeof(Peb32), lpNumberOfBytesRead) then
    RaiseLastOSError
  else
  begin
    //read the RTL_USER_PROCESS_PARAMETERS structure
    if not ReadProcessMemory(ProcessHandle, Pointer(Peb32.ProcessParameters), @Rtl32, SizeOf(Rtl32), lpNumberOfBytesRead) then
     RaiseLastOSError
    else
    begin
       //get the size of the Env. variables block
       if VirtualQueryEx(ProcessHandle, Pointer(Rtl32.Environment), Mbi, SizeOf(Mbi))=0 then
        RaiseLastOSError
       else
       EnvStrLength :=(mbi.RegionSize -(ULONG_PTR(Pointer(Rtl32.Environment)) - ULONG_PTR(mbi.BaseAddress)));

       SetLength(EnvStrBlock, EnvStrLength);
       //read the content of the env. variables block
       if not ReadProcessMemory(ProcessHandle, Pointer(Rtl32.Environment), @EnvStrBlock[0], EnvStrLength, lpNumberOfBytesRead) then
        RaiseLastOSError
       else
       Result:=TEncoding.Unicode.GetString(EnvStrBlock);
    end;
  end;

The source code

Finally this is the full source code.

program NtQueryInformationProcess_EnvVarsX64;
//Author Rodrigo Ruz (RRUZ)
//2012-06-09
{$APPTYPE CONSOLE}

{$IFNDEF UNICODE} this code only runs under unicode delphi versions{$ENDIF}
{$R *.res}
uses
  Classes,
  SysUtils,
  Windows;

type
  Pointer32 = ULONG;
  THANDLE32 = ULONG;

  _UNICODE_STRING = record
    Length: Word;
    MaximumLength: Word;
    Buffer: LPWSTR;
  end;
  UNICODE_STRING = _UNICODE_STRING;

  //http://msdn.microsoft.com/en-us/library/windows/desktop/ms684280%28v=vs.85%29.aspx
  PROCESS_BASIC_INFORMATION = record
    Reserved1 : Pointer;
    PebBaseAddress: Pointer;
    Reserved2: array [0..1] of Pointer;
    UniqueProcessId: ULONG_PTR;
    Reserved3: Pointer;
  end;


  //http://undocumented.ntinternals.net/UserMode/Structures/RTL_DRIVE_LETTER_CURDIR.html
  _RTL_DRIVE_LETTER_CURDIR = record
    Flags: Word;
    Length: Word;
    TimeStamp: ULONG;
    DosPath: UNICODE_STRING;
  end;
  RTL_DRIVE_LETTER_CURDIR = _RTL_DRIVE_LETTER_CURDIR;

   _CURDIR = record
    DosPath: UNICODE_STRING;
    Handle: THANDLE;
  end;
  CURDIR = _CURDIR;

 //http://undocumented.ntinternals.net/UserMode/Structures/RTL_USER_PROCESS_PARAMETERS.html
  _RTL_USER_PROCESS_PARAMETERS = record
    MaximumLength: ULONG;
    Length: ULONG;
    Flags: ULONG;
    DebugFlags: ULONG;
    ConsoleHandle: THANDLE;
    ConsoleFlags: ULONG;
    StandardInput: THANDLE;
    StandardOutput: THANDLE;
    StandardError: THANDLE;
    CurrentDirectory: CURDIR;
    DllPath: UNICODE_STRING;
    ImagePathName: UNICODE_STRING;
    CommandLine: UNICODE_STRING;
    Environment: Pointer;
    StartingX: ULONG;
    StartingY: ULONG;
    CountX: ULONG;
    CountY: ULONG;
    CountCharsX: ULONG;
    CountCharsY: ULONG;
    FillAttribute: ULONG;
    WindowFlags: ULONG;
    ShowWindowFlags: ULONG;
    WindowTitle: UNICODE_STRING;
    DesktopInfo: UNICODE_STRING;
    ShellInfo: UNICODE_STRING;
    RuntimeData: UNICODE_STRING;
    CurrentDirectories: array[0..31] of RTL_DRIVE_LETTER_CURDIR;
  end;
  RTL_USER_PROCESS_PARAMETERS = _RTL_USER_PROCESS_PARAMETERS;
  PRTL_USER_PROCESS_PARAMETERS = ^RTL_USER_PROCESS_PARAMETERS;

  _PEB = record
    Reserved1     : array [0..1] of Byte;
    BeingDebugged : Byte;
    Reserved2     : Byte;
    Reserved3     : array [0..1] of Pointer;
    Ldr           : Pointer;
    ProcessParameters : PRTL_USER_PROCESS_PARAMETERS;
    Reserved4     : array [0..102] of Byte;
    Reserved5     : array [0..51] of Pointer;
    PostProcessInitRoutine : Pointer;
    Reserved6     : array [0..127] of byte;
    Reserved7     : Pointer;
    SessionId     : ULONG;
  end;
   PEB=_PEB;

{$IFDEF CPUX64}
  _UNICODE_STRING32 = record
    Length: Word;
    MaximumLength: Word;
    Buffer: Pointer32;
  end;
  UNICODE_STRING32 = _UNICODE_STRING32;

  _RTL_DRIVE_LETTER_CURDIR32 = record
    Flags: Word;
    Length: Word;
    TimeStamp: ULONG;
    DosPath: UNICODE_STRING32;
  end;
  RTL_DRIVE_LETTER_CURDIR32 = _RTL_DRIVE_LETTER_CURDIR32;

   _CURDIR32 = record
    DosPath: UNICODE_STRING32;
    Handle: THANDLE32;
  end;
  CURDIR32 = _CURDIR32;

  _RTL_USER_PROCESS_PARAMETERS32 = record
    MaximumLength: ULONG;
    Length: ULONG;
    Flags: ULONG;
    DebugFlags: ULONG;
    ConsoleHandle: THANDLE32;
    ConsoleFlags: ULONG;
    StandardInput: THANDLE32;
    StandardOutput: THANDLE32;
    StandardError: THANDLE32;
    CurrentDirectory: CURDIR32;
    DllPath: UNICODE_STRING32;
    ImagePathName: UNICODE_STRING32;
    CommandLine: UNICODE_STRING32;
    Environment: Pointer32;
    StartingX: ULONG;
    StartingY: ULONG;
    CountX: ULONG;
    CountY: ULONG;
    CountCharsX: ULONG;
    CountCharsY: ULONG;
    FillAttribute: ULONG;
    WindowFlags: ULONG;
    ShowWindowFlags: ULONG;
    WindowTitle: UNICODE_STRING32;
    DesktopInfo: UNICODE_STRING32;
    ShellInfo: UNICODE_STRING32;
    RuntimeData: UNICODE_STRING32;
    CurrentDirectories: array[0..31] of RTL_DRIVE_LETTER_CURDIR32;
  end;
  RTL_USER_PROCESS_PARAMETERS32 = _RTL_USER_PROCESS_PARAMETERS32;
  PRTL_USER_PROCESS_PARAMETERS32 = ^RTL_USER_PROCESS_PARAMETERS32;

  _PEB32 = record
    Reserved1     : array [0..1] of Byte;
    BeingDebugged : Byte;
    Reserved2     : Byte;
    Reserved3     : array [0..1] of Pointer32;
    Ldr           : Pointer32;
    ProcessParameters : Pointer32;//PRTL_USER_PROCESS_PARAMETERS;
    Reserved4     : array [0..102] of Byte;
    Reserved5     : array [0..51] of Pointer32;
    PostProcessInitRoutine : Pointer32;
    Reserved6     : array [0..127] of byte;
    Reserved7     : Pointer32;
    SessionId     : ULONG;
  end;
   PEB32=_PEB32;
{$ENDIF}
  function  NtQueryInformationProcess(ProcessHandle : THandle; ProcessInformationClass : DWORD; ProcessInformation : Pointer; ProcessInformationLength : ULONG; ReturnLength : PULONG ): LongInt; stdcall; external 'ntdll.dll';
  function  NtQueryVirtualMemory(ProcessHandle : THandle; BaseAddress : Pointer;  MemoryInformationClass : DWORD;  MemoryInformation : Pointer;  MemoryInformationLength : ULONG; ReturnLength : PULONG ): LongInt; stdcall; external 'ntdll.dll';

type
  TIsWow64Process = function(Handle:THandle; var IsWow64 : BOOL) : BOOL; stdcall;
var
  _IsWow64Process  : TIsWow64Process;

procedure Init_IsWow64Process;
var
  hKernel32      : Integer;
begin
  hKernel32 := LoadLibrary(kernel32);
  if (hKernel32 = 0) then RaiseLastOSError;
  try
    _IsWow64Process := GetProcAddress(hkernel32, 'IsWow64Process');
  finally
    FreeLibrary(hKernel32);
  end;
end;

function ProcessIsX64(hProcess: DWORD): Boolean;
var
  IsWow64        : BOOL;
begin
  Result := False;
  {$IFNDEF CPUX64}
    exit;
  {$ENDIF}
  if not Assigned(_IsWow64Process) then
   Init_IsWow64Process;

  if Assigned(_IsWow64Process) then
  begin
    if (_IsWow64Process(hProcess, IsWow64)) then
      Result := not IsWow64
    else
      RaiseLastOSError;
  end;
end;

function GetEnvVarsPid(dwProcessId : DWORD): string;
const
  STATUS_SUCCESS             = $00000000;
  SE_DEBUG_NAME              = 'SeDebugPrivilege';
  ProcessWow64Information    = 26;
var
  ProcessHandle        : THandle;
  ProcessBasicInfo     : PROCESS_BASIC_INFORMATION;
  ReturnLength         : DWORD;
  lpNumberOfBytesRead  : ULONG_PTR;
  TokenHandle          : THandle;
  lpLuid               : TOKEN_PRIVILEGES;
  OldlpLuid            : TOKEN_PRIVILEGES;

  Rtl : RTL_USER_PROCESS_PARAMETERS;
  Mbi : TMemoryBasicInformation;
  Peb : _PEB;
  EnvStrBlock  : TBytes;
  EnvStrLength : ULONG;
  IsProcessx64 : Boolean;
  {$IFDEF CPUX64}
  PEBBaseAddress32 : Pointer;
  Peb32 : _PEB32;
  Rtl32 : RTL_USER_PROCESS_PARAMETERS32;
  {$ENDIF}
begin
  Result:='';
  if OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, TokenHandle) then
  begin
    try
      if not LookupPrivilegeValue(nil, SE_DEBUG_NAME, lpLuid.Privileges[0].Luid) then
        RaiseLastOSError
      else
      begin
        lpLuid.PrivilegeCount := 1;
        lpLuid.Privileges[0].Attributes  := SE_PRIVILEGE_ENABLED;
        ReturnLength := 0;
        OldlpLuid    := lpLuid;
        //Set the SeDebugPrivilege privilege
        if not AdjustTokenPrivileges(TokenHandle, False, lpLuid, SizeOf(OldlpLuid), OldlpLuid, ReturnLength) then RaiseLastOSError;
      end;

      ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, dwProcessId);
      if ProcessHandle=0 then RaiseLastOSError
      else
      try
        IsProcessx64 :=ProcessIsX64(ProcessHandle);

        {$IFNDEF CPUX64}
        if IsProcessx64 then
          raise Exception.Create('Only 32 bits processes are supported');
        {$ENDIF}

        {$IFDEF CPUX64}
        if IsProcessx64 then
        begin
        {$ENDIF}
          // get the PROCESS_BASIC_INFORMATION to access to the PEB Address
          if (NtQueryInformationProcess(ProcessHandle,0{=>ProcessBasicInformation},@ProcessBasicInfo, SizeOf(ProcessBasicInfo), @ReturnLength)=STATUS_SUCCESS) and (ReturnLength=SizeOf(ProcessBasicInfo)) then
          begin
            //read the PEB struture
            if not ReadProcessMemory(ProcessHandle, ProcessBasicInfo.PEBBaseAddress, @Peb, sizeof(Peb), lpNumberOfBytesRead) then
              RaiseLastOSError
            else
            begin
              //read the RTL_USER_PROCESS_PARAMETERS structure
              if not ReadProcessMemory(ProcessHandle, Peb.ProcessParameters, @Rtl, SizeOf(Rtl), lpNumberOfBytesRead) then
               RaiseLastOSError
              else
              begin
                 //get the size of the Env. variables block
                 if VirtualQueryEx(ProcessHandle, Rtl.Environment, Mbi, SizeOf(Mbi))=0 then
                  RaiseLastOSError
                 else
                 EnvStrLength :=(mbi.RegionSize -(ULONG_PTR(Rtl.Environment) - ULONG_PTR(mbi.BaseAddress)));

                 SetLength(EnvStrBlock, EnvStrLength);
                 //read the content of the env. variables block
                 if not ReadProcessMemory(ProcessHandle, Rtl.Environment, @EnvStrBlock[0], EnvStrLength, lpNumberOfBytesRead) then
                  RaiseLastOSError
                 else
                 Result:=TEncoding.Unicode.GetString(EnvStrBlock);
              end;
            end;
          end
          else
          RaiseLastOSError;
        {$IFDEF CPUX64}
        end
        else
        begin
          //get the PEB address
          if  NtQueryInformationProcess(ProcessHandle, ProcessWow64Information, @PEBBaseAddress32, SizeOf(PEBBaseAddress32), nil)=STATUS_SUCCESS then
          begin
            //read the PEB structure
            if not ReadProcessMemory(ProcessHandle, PEBBaseAddress32, @Peb32, sizeof(Peb32), lpNumberOfBytesRead) then
              RaiseLastOSError
            else
            begin
              //read the RTL_USER_PROCESS_PARAMETERS structure
              if not ReadProcessMemory(ProcessHandle, Pointer(Peb32.ProcessParameters), @Rtl32, SizeOf(Rtl32), lpNumberOfBytesRead) then
               RaiseLastOSError
              else
              begin
                 //get the size of the Env. variables block
                 if VirtualQueryEx(ProcessHandle, Pointer(Rtl32.Environment), Mbi, SizeOf(Mbi))=0 then
                  RaiseLastOSError
                 else
                 EnvStrLength :=(mbi.RegionSize -(ULONG_PTR(Pointer(Rtl32.Environment)) - ULONG_PTR(mbi.BaseAddress)));

                 SetLength(EnvStrBlock, EnvStrLength);
                 //read the content of the env. variables block
                 if not ReadProcessMemory(ProcessHandle, Pointer(Rtl32.Environment), @EnvStrBlock[0], EnvStrLength, lpNumberOfBytesRead) then
                  RaiseLastOSError
                 else
                 Result:=TEncoding.Unicode.GetString(EnvStrBlock);
              end;
            end;
          end
          else
          RaiseLastOSError;
        end;
       {$ENDIF}
      finally
        CloseHandle(ProcessHandle);
      end;
    finally
      CloseHandle(TokenHandle);
    end;
  end
  else
  RaiseLastOSError;
end;

function GetEnvVarsPidList(dwProcessId : DWORD): TStringList;
var
  PEnvVars: PChar;
  PEnvEntry: PChar;
begin
  Result:=TStringList.Create;
  PEnvVars := PChar(GetEnvVarsPid(dwProcessId));
  PEnvEntry := PEnvVars;
  while PEnvEntry^ <> #0 do
  begin
    Result.Add(PEnvEntry);
    Inc(PEnvEntry, StrLen(PEnvEntry) + 1);
  end;
end;

Var
  EnvVars : TStringList;
begin
  ReportMemoryLeaksOnShutdown:=True;
 try
   //Pass a valid pid here
   EnvVars:=GetEnvVarsPidList(5732);
   try
     Writeln(EnvVars.Text);
   finally
     EnvVars.Free;
   end;
 except
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Readln;
end.

Recommended resources


5 Comments

Getting the environment variables of an external x86 process

In this post I will show you how you can get the list of the environment variables of an external x86 process just like is done by tools like Process explorer or Process hacker.

To locate the Environment Variables of a process you must access the PEB (Process Enviroment Block) of the application and follow this secuence to resolve the address of this buffer.

PEB -> ProcessParameters(RTL_USER_PROCESS_PARAMETERS) ->  Environment (Pointer)

This is the definition of the PEB structure

typedef struct _PEB {
  BYTE                          Reserved1[2];
  BYTE                          BeingDebugged;
  BYTE                          Reserved2[1];
  PVOID                         Reserved3[2];
  PPEB_LDR_DATA                 Ldr;
  PRTL_USER_PROCESS_PARAMETERS  ProcessParameters;
  BYTE                          Reserved4[104];
  PVOID                         Reserved5[52];
  PPS_POST_PROCESS_INIT_ROUTINE PostProcessInitRoutine;
  BYTE                          Reserved6[128];
  PVOID                         Reserved7[1];
  ULONG                         SessionId;
} PEB, *PPEB;

And this is the definition of the RTL_USER_PROCESS_PARAMETERS.

typedef struct _RTL_USER_PROCESS_PARAMETERS
{
     ULONG MaximumLength;
     ULONG Length;
     ULONG Flags;
     ULONG DebugFlags;
     PVOID ConsoleHandle;
     ULONG ConsoleFlags;
     PVOID StandardInput;
     PVOID StandardOutput;
     PVOID StandardError;
     CURDIR CurrentDirectory;
     UNICODE_STRING DllPath;
     UNICODE_STRING ImagePathName;
     UNICODE_STRING CommandLine;
     PVOID Environment;
     ULONG StartingX;
     ULONG StartingY;
     ULONG CountX;
     ULONG CountY;
     ULONG CountCharsX;
     ULONG CountCharsY;
     ULONG FillAttribute;
     ULONG WindowFlags;
     ULONG ShowWindowFlags;
     UNICODE_STRING WindowTitle;
     UNICODE_STRING DesktopInfo;
     UNICODE_STRING ShellInfo;
     UNICODE_STRING RuntimeData;
     RTL_DRIVE_LETTER_CURDIR CurrentDirectores[32];
} RTL_USER_PROCESS_PARAMETERS, *PRTL_USER_PROCESS_PARAMETERS;

NtQueryInformationProcess and VirtualQueryEx

After of translate the above structures to delphi records, we need to get a pointer to the PEB of the process, this task must be done with the NtQueryInformationProcess function, passing the ProcessBasicInformation value in the ProcessInformationClass parameter, this will return a PROCESS_BASIC_INFORMATION structure having the following layout:

typedef struct _PROCESS_BASIC_INFORMATION {
    PVOID Reserved1;
    PPEB PebBaseAddress;
    PVOID Reserved2[2];
    ULONG_PTR UniqueProcessId;
    PVOID Reserved3;
} PROCESS_BASIC_INFORMATION;

Now using the ReadProcessMemory method you can read the PEB and the ProcessParameters (RTL_USER_PROCESS_PARAMETERS) of the application, to finally get the Pointer to the environment variables.

        // get the PROCESS_BASIC_INFORMATION to access to the PEB Address
        if (NtQueryInformationProcess(ProcessHandle,0{=>ProcessBasicInformation},@ProcessBasicInfo, SizeOf(ProcessBasicInfo), @ReturnLength)=STATUS_SUCCESS) and (ReturnLength=SizeOf(ProcessBasicInfo)) then
        begin
          //read the PEB struture
          if not ReadProcessMemory(ProcessHandle, ProcessBasicInfo.PEBBaseAddress, @Peb, sizeof(Peb), lpNumberOfBytesRead) then
            RaiseLastOSError
          else
          begin
            //read the RTL_USER_PROCESS_PARAMETERS structure
            if not ReadProcessMemory(ProcessHandle, Peb.ProcessParameters, @Rtl, SizeOf(Rtl), lpNumberOfBytesRead) then
             RaiseLastOSError

After of that we need calculate the size of the Env. variables buffer to read. This can be done using the VirtualQueryEx function which retieve the range of memory pages of the queried memory block and then using the ReadProcessMemory function again you can get the environment variables into a buffer.

Try this sample

//get the size of the Env. variables block
   if VirtualQueryEx(ProcessHandle, Rtl.Environment, Mbi, SizeOf(Mbi))=0 then
    RaiseLastOSError
   else
   EnvStrLength :=(mbi.RegionSize -(ULONG_PTR(Rtl.Environment) - ULONG_PTR(mbi.BaseAddress)));

   SetLength(EnvStrBlock, EnvStrLength);
   //read the content of the env. variables block
   if not ReadProcessMemory(ProcessHandle, Rtl.Environment, @EnvStrBlock[0], EnvStrLength, lpNumberOfBytesRead) then
    RaiseLastOSError
   else
   {$IFDEF UNICODE}
   Result:=TEncoding.Unicode.GetString(EnvStrBlock);
   {$ELSE}
   SetString(WS, PWideChar(@EnvStrBlock[0]), Length(EnvStrBlock) div 2);
   Result:=WS;
   {$ENDIF}

The source code

Finally this is the full source code to read the environment variables of an external x86 process, the code was tested from Delphi 2007 to XE2 under WinXP and Windows 7.

program NtQueryInformationProcess_EnvVars;
//Author Rodrigo Ruz (RRUZ)
//2012-05-26
{$APPTYPE CONSOLE}
{$IFDEF CPUX64} Sorry only 32 bits support{$ENDIF}
{$R *.res}
uses
  Classes,
  SysUtils,
  Windows;

type
  _UNICODE_STRING = record
    Length: Word;
    MaximumLength: Word;
    Buffer: LPWSTR;
  end;
  UNICODE_STRING = _UNICODE_STRING;

  //http://msdn.microsoft.com/en-us/library/windows/desktop/ms684280%28v=vs.85%29.aspx
  PROCESS_BASIC_INFORMATION = record
    Reserved1 : Pointer;
    PebBaseAddress: Pointer;
    Reserved2: array [0..1] of Pointer;
    UniqueProcessId: ULONG_PTR;
    Reserved3: Pointer;
  end;

  //http://undocumented.ntinternals.net/UserMode/Structures/RTL_DRIVE_LETTER_CURDIR.html
  _RTL_DRIVE_LETTER_CURDIR = record
    Flags: Word;
    Length: Word;
    TimeStamp: ULONG;
    DosPath: UNICODE_STRING;
  end;
  RTL_DRIVE_LETTER_CURDIR = _RTL_DRIVE_LETTER_CURDIR;

  _CURDIR = record
    DosPath: UNICODE_STRING;
    Handle: THANDLE;
  end;
  CURDIR = _CURDIR;

  //http://undocumented.ntinternals.net/UserMode/Structures/RTL_USER_PROCESS_PARAMETERS.html
  _RTL_USER_PROCESS_PARAMETERS = record
    MaximumLength: ULONG;
    Length: ULONG;
    Flags: ULONG;
    DebugFlags: ULONG;
    ConsoleHandle: THANDLE;
    ConsoleFlags: ULONG;
    StandardInput: THANDLE;
    StandardOutput: THANDLE;
    StandardError: THANDLE;
    CurrentDirectory: CURDIR;
    DllPath: UNICODE_STRING;
    ImagePathName: UNICODE_STRING;
    CommandLine: UNICODE_STRING;
    Environment: Pointer;
    StartingX: ULONG;
    StartingY: ULONG;
    CountX: ULONG;
    CountY: ULONG;
    CountCharsX: ULONG;
    CountCharsY: ULONG;
    FillAttribute: ULONG;
    WindowFlags: ULONG;
    ShowWindowFlags: ULONG;
    WindowTitle: UNICODE_STRING;
    DesktopInfo: UNICODE_STRING;
    ShellInfo: UNICODE_STRING;
    RuntimeData: UNICODE_STRING;
    CurrentDirectories: array[0..31] of RTL_DRIVE_LETTER_CURDIR;
  end;
  RTL_USER_PROCESS_PARAMETERS = _RTL_USER_PROCESS_PARAMETERS;
  PRTL_USER_PROCESS_PARAMETERS = ^RTL_USER_PROCESS_PARAMETERS;

  _PEB = record
    Reserved1     : array [0..1] of Byte;
    BeingDebugged : Byte;
    Reserved2     : Byte;
    Reserved3     : array [0..1] of Pointer;
    Ldr           : Pointer;
    ProcessParameters : PRTL_USER_PROCESS_PARAMETERS;
    Reserved4     : array [0..102] of Byte;
    Reserved5     : array [0..51] of Pointer;
    PostProcessInitRoutine : Pointer;
    Reserved6     : array [0..127] of byte;
    Reserved7     : Pointer;
    SessionId     : ULONG;
  end;
   PEB=_PEB;


  function  NtQueryInformationProcess(ProcessHandle : THandle; ProcessInformationClass : DWORD; ProcessInformation : Pointer; ProcessInformationLength : ULONG; ReturnLength : PULONG ): LongInt; stdcall; external 'ntdll.dll';

type
  TIsWow64Process = function(Handle:THandle; var IsWow64 : BOOL) : BOOL; stdcall;
var
  _IsWow64Process  : TIsWow64Process;

procedure Init_IsWow64Process;
var
  hKernel32      : Integer;
begin
  hKernel32 := LoadLibrary(kernel32);
  if (hKernel32 = 0) then RaiseLastOSError;
  try
    _IsWow64Process := GetProcAddress(hkernel32, 'IsWow64Process');
  finally
    FreeLibrary(hKernel32);
  end;
end;

function ProcessIsX64(hProcess: DWORD): Boolean;
var
  IsWow64        : BOOL;
  PidHandle      : THandle;
begin
  Result := False;
  if not Assigned(_IsWow64Process) then
   Init_IsWow64Process;

  if Assigned(_IsWow64Process) then
  begin
    //check if the current app is running under WOW
    if _IsWow64Process(GetCurrentProcess(), IsWow64) then
      Result := IsWow64
    else
      RaiseLastOSError;

    {$IFNDEF CPUX64}
    //the current delphi App is not running under wow64, so the current Window OS is 32 bit
    //and obviously all the apps are 32 bits.
    if not Result then Exit;
    {$ENDIF}

    if (_IsWow64Process(hProcess, IsWow64)) then
      Result := not IsWow64
    else
      RaiseLastOSError;
  end;
end;

function GetEnvVarsPid(dwProcessId : DWORD): string;
const
  STATUS_SUCCESS             = $00000000;
  SE_DEBUG_NAME              = 'SeDebugPrivilege';
  OffsetProcessParametersx32 = $10;
var
  ProcessHandle        : THandle;
  ProcessBasicInfo     : PROCESS_BASIC_INFORMATION;
  ReturnLength         : DWORD;
  lpNumberOfBytesRead  : ULONG_PTR;
  TokenHandle          : THandle;
  lpLuid               : TOKEN_PRIVILEGES;
  OldlpLuid            : TOKEN_PRIVILEGES;

  Rtl : RTL_USER_PROCESS_PARAMETERS;
  Mbi : TMemoryBasicInformation;
  Peb : _PEB;
  EnvStrBlock  : TBytes;
  EnvStrLength : ULONG;
  {$IFNDEF UNICODE}
  WS : WideString;
  {$ENDIF}
begin
  Result:='';
  if OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, TokenHandle) then
  begin
    try
      if not LookupPrivilegeValue(nil, SE_DEBUG_NAME, lpLuid.Privileges[0].Luid) then
        RaiseLastOSError
      else
      begin
        lpLuid.PrivilegeCount := 1;
        lpLuid.Privileges[0].Attributes  := SE_PRIVILEGE_ENABLED;
        ReturnLength := 0;
        OldlpLuid    := lpLuid;
        //Set the SeDebugPrivilege privilege
        if not AdjustTokenPrivileges(TokenHandle, False, lpLuid, SizeOf(OldlpLuid), OldlpLuid, ReturnLength) then RaiseLastOSError;
      end;

      ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, false, dwProcessId);
      if ProcessHandle=0 then RaiseLastOSError
      else
      try
        if ProcessIsX64(ProcessHandle) then
         raise Exception.Create('Only 32 bits processes are supported');

        // get the PROCESS_BASIC_INFORMATION to access to the PEB Address
        if (NtQueryInformationProcess(ProcessHandle,0{=>ProcessBasicInformation},@ProcessBasicInfo, SizeOf(ProcessBasicInfo), @ReturnLength)=STATUS_SUCCESS) and (ReturnLength=SizeOf(ProcessBasicInfo)) then
        begin
          //read the PEB struture
          if not ReadProcessMemory(ProcessHandle, ProcessBasicInfo.PEBBaseAddress, @Peb, sizeof(Peb), lpNumberOfBytesRead) then
            RaiseLastOSError
          else
          begin
            //read the RTL_USER_PROCESS_PARAMETERS structure
            if not ReadProcessMemory(ProcessHandle, Peb.ProcessParameters, @Rtl, SizeOf(Rtl), lpNumberOfBytesRead) then
             RaiseLastOSError
            else
            begin
             //get the size of the Env. variables block
             if VirtualQueryEx(ProcessHandle, Rtl.Environment, Mbi, SizeOf(Mbi))=0 then
              RaiseLastOSError
             else
             EnvStrLength :=(mbi.RegionSize -(ULONG_PTR(Rtl.Environment) - ULONG_PTR(mbi.BaseAddress)));

             SetLength(EnvStrBlock, EnvStrLength);
             //read the content of the env. variables block
             if not ReadProcessMemory(ProcessHandle, Rtl.Environment, @EnvStrBlock[0], EnvStrLength, lpNumberOfBytesRead) then
              RaiseLastOSError
             else
             {$IFDEF UNICODE}
             Result:=TEncoding.Unicode.GetString(EnvStrBlock);
             {$ELSE}
             {
             SetLength(Result, Length(EnvStrBlock) div 2);
             WideCharToMultiByte( CP_ACP , 0, PWideChar(@EnvStrBlock[0]), -1, @Result[1], Rtl.EnvironmentSize, nil, nil );
             }
             SetString(WS, PWideChar(@EnvStrBlock[0]), Length(EnvStrBlock) div 2);
             Result:=WS;
             {$ENDIF}

            end;
          end;
        end
        else
        RaiseLastOSError;
      finally
        CloseHandle(ProcessHandle);
      end;
    finally
      CloseHandle(TokenHandle);
    end;
  end
  else
  RaiseLastOSError;
end;


function GetEnvVarsPidList(dwProcessId : DWORD): TStringList;
var
  PEnvVars: PChar;
  PEnvEntry: PChar;
begin
  Result:=TStringList.Create;
  PEnvVars := PChar(GetEnvVarsPid(dwProcessId));
  PEnvEntry := PEnvVars;
  while PEnvEntry^ <> #0 do
  begin
    Result.Add(PEnvEntry);
    Inc(PEnvEntry, StrLen(PEnvEntry) + 1);
  end;
end;

Var
  EnvVars : TStringList;
begin
  ReportMemoryLeaksOnShutdown:=True;
 try
   EnvVars:=GetEnvVarsPidList(4724);
   try
     Writeln(EnvVars.Text);
   finally
     EnvVars.Free;
   end;
 except
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Readln;
end.

Recommended resources


3 Comments

Determine Genuine Windows Installation using Delphi

Starting with Windows Vista , Microsoft introduces the The Software Licensing API (SLAPI), this API can be used to determine a genuine Microsoft Windows installation.

So using the SLIsGenuineLocal function you can check if your app is running in a genuine Windows installation.

This is the definition of the function

HRESULT WINAPI SLIsGenuineLocal(
  __in         const SLID *pAppId,
  __out        SL_GENUINE_STATE *pGenuineState,
  __inout_opt  SL_NONGENUINE_UI_OPTIONS *pUIOptions
);

The use of this funtion is very easy, only you must pass the GUID (Application Id) of Windows {55c92734-d682-4d71-983e-d6ec3f16059f} and a variable of type SL_GENUINE_STATE to receive the status of the license.

Check this delphi implementation

{$APPTYPE CONSOLE}
uses
  Windows,
  SysUtils;

type
  SLID  = TGUID;
  _SL_GENUINE_STATE = (
    SL_GEN_STATE_IS_GENUINE        = 0,
    SL_GEN_STATE_INVALID_LICENSE   = 1,
    SL_GEN_STATE_TAMPERED          = 2,
    SL_GEN_STATE_LAST              = 3
  );
  SL_GENUINE_STATE = _SL_GENUINE_STATE;

function SLIsGenuineLocal(var pAppId: SLID; var pGenuineState: SL_GENUINE_STATE; pUIOptions: Pointer): HRESULT; stdcall; external 'Slwga.dll' name 'SLIsGenuineLocal' delayed;

Var
  pAppId : SLID;
  pGenuineState: SL_GENUINE_STATE;
  Status: HRESULT;
begin
  try
    if Win32MajorVersion>= 6 then //Windows Vista o newer
    begin
      pAppId:=StringToGUID('{55C92734-D682-4D71-983E-D6EC3F16059F}');
      Status:=SLIsGenuineLocal(pAppId, pGenuineState,nil);
      if Succeeded(Status) then
        case pGenuineState of
            SL_GEN_STATE_IS_GENUINE       : Writeln('The installation is genuine.');
            SL_GEN_STATE_INVALID_LICENSE  : Writeln('The application does not have a valid license.');
            SL_GEN_STATE_TAMPERED         : Writeln('The Tampered flag of the license associated with the application is set.');
            SL_GEN_STATE_LAST             : Writeln('The state of the installation has not changed since the last time it was checked.');
        end
      else
        Writeln(SysErrorMessage(Cardinal(Status)));
    end
    else
        Writeln('OS not supported');
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.

In windows XP does not exist the SLAPI, but you can use the Win32_WindowsProductActivation WMI class to get simmilar information. the key is check the ActivationRequired property, If return 1 then the system activation is pending for the system. else If returns 0 (zero) the activation is not required.

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj,
  Variants;

procedure  GetWin32_WindowsProductActivationInfo;
const
  WbemUser            ='';
  WbemPassword        ='';
  WbemComputer        ='localhost';
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;

  if (Win32MajorVersion=5) and (Win32MinorVersion=1) then
  begin
    NullStrictConvert :=False;
    FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
    FWMIService   := FSWbemLocator.ConnectServer(WbemComputer, 'root\CIMV2', WbemUser, WbemPassword);
    FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_WindowsProductActivation','WQL',wbemFlagForwardOnly);
    oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
    while oEnum.Next(1, FWbemObject, iValue) = 0 do
    begin
      Writeln(Format('Windows is Activated  %s',[BooltoStr(FWbemObject.ActivationRequired=0,True)]));
      Writeln(Format('ActivationRequired    %d',[Integer(FWbemObject.ActivationRequired)]));
      Writeln(Format('Description           %s',[String(FWbemObject.Description)]));
      Writeln(Format('ProductID             %s',[String(FWbemObject.ProductID)]));
      if FWbemObject.ActivationRequired=1 then
      begin
        Writeln(Format('RemainingEvaluationPeriod    %d',[Integer(FWbemObject.RemainingEvaluationPeriod)]));
        Writeln(Format('RemainingGracePeriod         %d',[Integer(FWbemObject.RemainingGracePeriod)]));
      end;
      Writeln(Format('ServerName            %s',[String(FWbemObject.ServerName)]));
      Writeln(Format('SettingID             %s',[String(FWbemObject.SettingID)]));

      Writeln;
      FWbemObject:=Unassigned;
    end;
  end
  else
  Writeln('OS not supported');
end;


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