The Road to Delphi

Delphi – Free Pascal – Oxygene


20 Comments

Reading the SMBios Tables using Delphi

UPDATE : If you want access the SMBIOS using Delphi or Free Pascal try the TSMBIOS project.


 

The system management BIOS (SMBIOS)   is a specification of how the system vendors present management information about their products in a standard format, so you can use the  SMBIOS to discover information about the hardware platform, such as the system manufacturer, the system BIOS version, processor installed characteristics  and so on. From windows you can acceess the SMBIOS tables using the WMI or the WinApi. In this article I will show how  you can gain access to the SMBios tables using the WMI and Delphi.

The SMBIOS Tables

The tables are located directly adjacent to each other in memory. Each table is composed of a 4-byte header, a specific structure , and an optional string table.

Header

This is the header description of each table

The type field present in the header define how each table must be interpreted, this is a list of a few table types

  • BIOS Information (Type 0)
  • System Information (Type 1)
  • System Enclosure (Type 3)
  • Processor Information (Type 4)
  • Cache Information (Type 7)
  • System Slots (Type 9)
  • Physical Memory Array (Type 16)
  • Memory Device (Type 17)
  • Memory Array Mapped Address (Type 19)
  • System Boot Information (Type 32)

Text Strings

The text strings associated with a given SMBIOS table are appended directly after the formatted portion of the structure. Each string is terminated with a null (00h) BYTE and the set of strings is terminated with an additional null (00h) BYTE. When the formatted portion of a SMBIOS structure references a string, it does so by specifying a non-zero string number within the structure’s string-set. For example, if a string field contains 02h, it references the second string following the formatted portion of the SMBIOS structure. If a string field references no string, a null (0) is placed in that string field.

Check the next representation of a BIOS Table (Type


 db 0 ; Indicates BIOS Structure Type            |
 db 13h ; Length of information in bytes         | Header of the table
 dw ? ; Reserved for handle                      |

 db 01h ; String 1 is the Vendor Name            |
 db 02h ; String 2 is the BIOS version           |
 dw 0E800h ; BIOS Starting Address               |
 db 03h ; String 3 is the BIOS Build Date        | formatted portion
 db 1 ; Size of BIOS ROM is 128K (64K * (1 + 1)) |
 dq BIOS_Char ; BIOS Characteristics             |
 db 0 ; BIOS Characteristics Extension Byte 1    |

 db ‘System BIOS Vendor Name’,0 ;                |
 db ‘4.04’,0 ;                                   | Text Strings (unformatted portion)
 db ‘00/00/0000’,0 ;                             |

 db 0 ; End of structure

WMI

Now which you know the basics about the SMBios table structures, you need a way to retrieve such tables.  the WMI provides a way to get  the raw SMBIOS data in a single buffer using the class MSSmBios_RawSMBiosTables this class is in the root\WMI namespace and is available since Windows XP.

Check this small snippet to retrieve the SMBios tables buffer contained in the SMBiosData property

const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
  vArray        : variant;
  Value         : integer;
  i             : integer;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  //connect to the Wmi service
  FWMIService := FSWbemLocator.ConnectServer('localhost', 'root\WMI', '', '');
  //execute the WQL sentence
  FWbemObjectSet := FWMIService.ExecQuery('SELECT * FROM MSSmBios_RawSMBiosTables', 'WQL', wbemFlagForwardOnly);
  oEnum := IUnknown(FWbemObjectSet._NewEnum) as IEnumvariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    //store the size of the buffer
    FSize := FWbemObject.Size;
    GetMem(FBuffer, FSize);
    //get the addtional properties like the SMBIos version
    FDmiRevision:= FWbemObject.DmiRevision;
    FSmbiosMajorVersion :=FWbemObject.SmbiosMajorVersion;
    FSmbiosMinorVersion :=FWbemObject.SmbiosMinorVersion;

    //get the buffer of the SMBios tables
    vArray := FWbemObject.SMBiosData;

    FWbemObject := Unassigned;
  end;
end;

Delphi

From the Delphi side we need to create a few structures to hold the data of the tables and write some helper functions to parse the information.

type
  // http://www.dmtf.org/standards/smbios
  SMBiosTables = (
    BIOSInformation = 0,
    SystemInformation = 1,
    BaseBoardInformation = 2,
    EnclosureInformation = 3,
    ProcessorInformation = 4,
    MemoryControllerInformation = 5,
    MemoryModuleInformation = 6,
    CacheInformation = 7,
    PortConnectorInformation = 8,
    SystemSlotsInformation = 9,
    OnBoardDevicesInformation = 10,
    OEMStrings = 11,
    SystemConfigurationOptions = 12,
    BIOSLanguageInformation = 13,
    GroupAssociations = 14,
    SystemEventLog = 15,
    PhysicalMemoryArray = 16,
    MemoryDevice = 17,
    MemoryErrorInformation = 18,
    MemoryArrayMappedAddress = 19,
    MemoryDeviceMappedAddress = 20,
    EndofTable = 127); //for more tables check the official specifications http://www.dmtf.org/standards/smbios

  //the header of each SMBios table
  TSmBiosTableHeader = packed record
    TableType: Byte;
    Length: Byte;
    Handle: Word;
  end;

  //this is a helper record to store the header and index of each table stored in the buffer
  TSMBiosTableEntry = record
    Header: TSmBiosTableHeader;
    Index : Integer;
  end;

  //this is the record to store Bios information about the table Type 0
  TBiosInfo = packed record
    Header: TSmBiosTableHeader;
    Vendor: Byte;
    Version: Byte;
    StartingSegment: Word;
    ReleaseDate: Byte;
    BiosRomSize: Byte;
    Characteristics: Int64;
    ExtensionBytes : array [0..1] of Byte;
  end;

The next code show how you can parse the buffer with the raw data and fill a Generic TList of TSMBiosTableEntry records.

function GetSMBiosTablesList(Buffer : PByteArray): TList;
Var
  Index : integer;
  Header: TSmBiosTableHeader;
  Entry : TSMBiosTableEntry;
begin
  Result    := TList.Create;
  Index     := 0;
  repeat
    //read the header
    Move(Buffer[Index], Header, SizeOf(Header));
    Entry.Header:=Header;
    Entry.Index:=Index;
    //add to the list
    Result.Add(Entry);

    //check if the tale type is 127 (end of tables)
    if Header.TableType=Ord(SMBiosTables.EndofTable) then break;

    //increase the Index in the length of the formatted data
    inc(Index, Header.Length);

    //Text strings zone

    //check for the boundaries of the buffer
    if Index+1>FSize then
      Break;

    //check for $00 $00 -> table termination
    while not((Buffer[Index] = 0) and (Buffer[Index + 1] = 0)) do
    if Index+1>FSize then
     Break
    else
     inc(Index);

    inc(Index, 2);
  until (Index>FSize);
end;

Now to retrieve a text string from a SMBios table

//the Entry Parameter is the buffer to the unformatted data
//The index is the number of the text string to retrieve
function GetSMBiosString(Entry, Index: integer): AnsiString;
var
  i: integer;
  p: PAnsiChar;
begin
  Result := '';
  for i := 1 to Index do
  begin
    p := PAnsiChar(@Buffer[Entry]);
    if i = Index then
    begin
      Result := p;
      break;
    end
    else
      inc(Entry, StrLen(p) + 1);
  end;
end;

A unit to retrieve the Smbios tables

Here I leave a unit to retrieve and parse the SMBios tables, the unit does not cover all the tables types (you can read the official specification)

//Author Rodrigo Ruz V.
//2011-08-01

unit uSMBIOS;

interface

uses
  SysUtils,
  Windows,
  Generics.Collections,
  Classes;

type
  // http://www.dmtf.org/standards/smbios
  SMBiosTables = (
    BIOSInformation = 0,
    SystemInformation = 1,
    BaseBoardInformation = 2,
    EnclosureInformation = 3,
    ProcessorInformation = 4,
    MemoryControllerInformation = 5,
    MemoryModuleInformation = 6,
    CacheInformation = 7,
    PortConnectorInformation = 8,
    SystemSlotsInformation = 9,
    OnBoardDevicesInformation = 10,
    OEMStrings = 11,
    SystemConfigurationOptions = 12,
    BIOSLanguageInformation = 13,
    GroupAssociations = 14,
    SystemEventLog = 15,
    PhysicalMemoryArray = 16,
    MemoryDevice = 17,
    MemoryErrorInformation = 18,
    MemoryArrayMappedAddress = 19,
    MemoryDeviceMappedAddress = 20,
    EndofTable = 127);

  TSmBiosTableHeader = packed record
    TableType: Byte;
    Length: Byte;
    Handle: Word;
  end;

  TBiosInfo = packed record
    Header: TSmBiosTableHeader;
    Vendor: Byte;
    Version: Byte;
    StartingSegment: Word;
    ReleaseDate: Byte;
    BiosRomSize: Byte;
    Characteristics: Int64;
    ExtensionBytes : array [0..1] of Byte;
  end;

  TSysInfo = packed record
    Header: TSmBiosTableHeader;
    Manufacturer: Byte;
    ProductName: Byte;
    Version: Byte;
    SerialNumber: Byte;
    UUID: array [0 .. 15] of Byte;
    WakeUpType: Byte;
  end;

  TBaseBoardInfo = packed record
    Header: TSmBiosTableHeader;
    Manufacturer: Byte;
    Product: Byte;
    Version: Byte;
    SerialNumber: Byte;
  end;

  TEnclosureInfo = packed record
    Header: TSmBiosTableHeader;
    Manufacturer: Byte;
    &Type: Byte;
    Version: Byte;
    SerialNumber: Byte;
    AssetTagNumber: Byte;
    BootUpState: Byte;
    PowerSupplyState: Byte;
    ThermalState: Byte;
    SecurityStatus: Byte;
    OEM_Defined: DWORD;
  end;

  TProcessorInfo = packed record
    Header: TSmBiosTableHeader;
    SocketDesignation: Byte;
    ProcessorType: Byte;
    ProcessorFamily: Byte;
    ProcessorManufacturer: Byte;
    ProcessorID: Int64; // QWORD;
    ProcessorVersion: Byte;
    Voltaje: Byte;
    ExternalClock: Word;
    MaxSpeed: Word;
    CurrentSpeed: Word;
    Status: Byte;
    ProcessorUpgrade: Byte;
    L1CacheHandler: Word;
    L2CacheHandler: Word;
    L3CacheHandler: Word;
    SerialNumber: Byte;
    AssetTag: Byte;
    PartNumber: Byte;
  end;

  TCacheInfo = packed record
    Header: TSmBiosTableHeader;
    SocketDesignation: Byte;
    CacheConfiguration: DWORD;
    MaximumCacheSize: Word;
    InstalledSize: Word;
    SupportedSRAMType: Word;
    CurrentSRAMType: Word;
    CacheSpeed: Byte;
    ErrorCorrectionType: Byte;
    SystemCacheType: Byte;
    Associativity: Byte;
  end;

  TSMBiosTableEntry = record
    Header: TSmBiosTableHeader;
    Index : Integer;
  end;

  TSMBios = class
  private
    FSize: integer;
    FBuffer: PByteArray;
    FDataString: AnsiString;
    FBiosInfo: TBiosInfo;
    FSysInfo: TSysInfo;
    FBaseBoardInfo: TBaseBoardInfo;
    FEnclosureInfo: TEnclosureInfo;
    FProcessorInfo: TProcessorInfo;
    FBiosInfoIndex: Integer;
    FSysInfoIndex: Integer;
    FBaseBoardInfoIndex: Integer;
    FEnclosureInfoIndex: Integer;
    FProcessorInfoIndex: Integer;
    FDmiRevision: Integer;
    FSmbiosMajorVersion: Integer;
    FSmbiosMinorVersion: Integer;
    FSMBiosTablesList: TList;
    procedure LoadSMBIOS;
    procedure ReadSMBiosTables;
    function GetHasBiosInfo: Boolean;
    function GetHasSysInfo: Boolean;
    function GetHasBaseBoardInfo: Boolean;
    function GetHasEnclosureInfo: Boolean;
    function GetHasProcessorInfo: Boolean;
    function GetSMBiosTablesList:TList;
  public
    constructor Create;
    destructor Destroy; override;

    function SearchSMBiosTable(TableType: SMBiosTables): integer;
    function GetSMBiosTableIndex(TableType: SMBiosTables): integer;
    function GetSMBiosString(Entry, Index: integer): AnsiString;

    property Size: integer read FSize;
    property Buffer: PByteArray read FBuffer;
    property DataString: AnsiString read FDataString;
    property DmiRevision: Integer read FDmiRevision;
    property SmbiosMajorVersion : Integer read FSmbiosMajorVersion;
    property SmbiosMinorVersion : Integer read FSmbiosMinorVersion;
    property SMBiosTablesList : TList read FSMBiosTablesList;

    property BiosInfo: TBiosInfo read FBiosInfo Write FBiosInfo;
    property BiosInfoIndex: Integer read FBiosInfoIndex Write FBiosInfoIndex;
    property HasBiosInfo : Boolean read GetHasBiosInfo;
    property SysInfo: TSysInfo read FSysInfo Write FSysInfo;
    property SysInfoIndex: Integer read FSysInfoIndex Write FSysInfoIndex;
    property HasSysInfo : Boolean read GetHasSysInfo;
    property BaseBoardInfo: TBaseBoardInfo read FBaseBoardInfo write FBaseBoardInfo;
    property BaseBoardInfoIndex: Integer read FBaseBoardInfoIndex Write FBaseBoardInfoIndex;
    property HasBaseBoardInfo : Boolean read GetHasBaseBoardInfo;
    property EnclosureInfo: TEnclosureInfo read FEnclosureInfo write FEnclosureInfo;
    property EnclosureInfoIndex: Integer read FEnclosureInfoIndex Write FEnclosureInfoIndex;
    property HasEnclosureInfo : Boolean read GetHasEnclosureInfo;
    property ProcessorInfo: TProcessorInfo read FProcessorInfo write FProcessorInfo;
    property ProcessorInfoIndex: Integer read FProcessorInfoIndex Write FProcessorInfoIndex;
    property HasProcessorInfo : Boolean read GetHasProcessorInfo;
  end;

implementation

uses
  ComObj,
  ActiveX,
  Variants;

{ TSMBios }
constructor TSMBios.Create;
begin
  Inherited;
  FBuffer := nil;
  FSMBiosTablesList:=nil;
  LoadSMBIOS;
  ReadSMBiosTables;
end;

destructor TSMBios.Destroy;
begin
  if Assigned(FBuffer) and (FSize > 0) then
    FreeMem(FBuffer);

  if Assigned(FSMBiosTablesList) then
    FSMBiosTablesList.Free;

  Inherited;
end;

function TSMBios.GetHasBaseBoardInfo: Boolean;
begin
  Result:=FBaseBoardInfoIndex>=0;
end;

function TSMBios.GetHasBiosInfo: Boolean;
begin
  Result:=FBiosInfoIndex>=0;
end;

function TSMBios.GetHasEnclosureInfo: Boolean;
begin
  Result:=FEnclosureInfoIndex>=0;
end;

function TSMBios.GetHasProcessorInfo: Boolean;
begin
  Result:=FProcessorInfoIndex>=0;
end;

function TSMBios.GetHasSysInfo: Boolean;
begin
  Result:=FSysInfoIndex>=0;
end;

function TSMBios.SearchSMBiosTable(TableType: SMBiosTables): integer;
Var
  Index  : integer;
  Header : TSmBiosTableHeader;
begin
  Index     := 0;
  repeat
    Move(Buffer[Index], Header, SizeOf(Header));

    if Header.TableType = Ord(TableType) then
      break
    else
    begin
       inc(Index, Header.Length);
       if Index+1>FSize then
       begin
         Index:=-1;
         Break;
       end;

      while not((Buffer[Index] = 0) and (Buffer[Index + 1] = 0)) do
       if Index+1>FSize then
       begin
         Index:=-1;
         Break;
       end
       else
       inc(Index);

       inc(Index, 2);
    end;
  until (Index>FSize);
  Result := Index;
end;

function TSMBios.GetSMBiosString(Entry, Index: integer): AnsiString;
var
  i: integer;
  p: PAnsiChar;
begin
  Result := '';
  for i := 1 to Index do
  begin
    p := PAnsiChar(@Buffer[Entry]);
    if i = Index then
    begin
      Result := p;
      break;
    end
    else
      inc(Entry, StrLen(p) + 1);
  end;
end;

function TSMBios.GetSMBiosTableIndex(TableType: SMBiosTables): integer;
Var
 Entry : TSMBiosTableEntry;
begin
 Result:=-1;
  for Entry in FSMBiosTablesList do
    if Entry.Header.TableType=Ord(TableType)  then
    begin
      Result:=Entry.Index;
      Break;
    end;
end;

function TSMBios.GetSMBiosTablesList: TList;
Var
  Index : integer;
  Header: TSmBiosTableHeader;
  Entry    : TSMBiosTableEntry;
begin
  Result    := TList.Create;
  Index     := 0;
  repeat
    Move(Buffer[Index], Header, SizeOf(Header));
    Entry.Header:=Header;
    Entry.Index:=Index;
    Result.Add(Entry);

    if Header.TableType=Ord(SMBiosTables.EndofTable) then break;

    inc(Index, Header.Length);// + 1);
    if Index+1>FSize then
      Break;

    while not((Buffer[Index] = 0) and (Buffer[Index + 1] = 0)) do
    if Index+1>FSize then
     Break
    else
     inc(Index);

    inc(Index, 2);
  until (Index>FSize);
end;

procedure TSMBios.LoadSMBIOS;
const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator: OLEVariant;
  FWMIService: OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject: OLEVariant;
  oEnum: IEnumvariant;
  iValue: LongWord;
  vArray: variant;
  Value: integer;
  i: integer;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService := FSWbemLocator.ConnectServer('localhost', 'root\WMI', '', '');
  FWbemObjectSet := FWMIService.ExecQuery('SELECT * FROM MSSmBios_RawSMBiosTables', 'WQL', wbemFlagForwardOnly);
  oEnum := IUnknown(FWbemObjectSet._NewEnum) as IEnumvariant;
  if oEnum.Next(1, FWbemObject, iValue) = 0 then
  begin
    FSize := FWbemObject.Size;
    GetMem(FBuffer, FSize);

    FDmiRevision:= FWbemObject.DmiRevision;
    FSmbiosMajorVersion :=FWbemObject.SmbiosMajorVersion;
    FSmbiosMinorVersion :=FWbemObject.SmbiosMinorVersion;

    vArray := FWbemObject.SMBiosData;

    if (VarType(vArray) and VarArray) <> 0 then
      for i := VarArrayLowBound(vArray, 1) to VarArrayHighBound(vArray, 1) do
      begin
        Value := vArray[i];
        Buffer[i] := Value;
        if Value in [$20..$7E] then
          FDataString := FDataString + AnsiString(Chr(Value))
        else
          FDataString := FDataString + '.';
      end;

    FSMBiosTablesList:=GetSMBiosTablesList;
    FWbemObject := Unassigned;
  end;
end;

procedure TSMBios.ReadSMBiosTables;
begin
  FBiosInfoIndex := GetSMBiosTableIndex(BIOSInformation);
  if FBiosInfoIndex >= 0 then
    Move(Buffer[FBiosInfoIndex], FBiosInfo, SizeOf(FBiosInfo));

  FSysInfoIndex := GetSMBiosTableIndex(SystemInformation);
  if FSysInfoIndex >= 0 then
    Move(Buffer[FSysInfoIndex], FSysInfo, SizeOf(FSysInfo));

  FBaseBoardInfoIndex := GetSMBiosTableIndex(BaseBoardInformation);
  if FBaseBoardInfoIndex >= 0 then
    Move(Buffer[FBaseBoardInfoIndex], FBaseBoardInfo, SizeOf(FBaseBoardInfo));

  FEnclosureInfoIndex := GetSMBiosTableIndex(EnclosureInformation);
  if FEnclosureInfoIndex >= 0 then
    Move(Buffer[FEnclosureInfoIndex], FEnclosureInfo, SizeOf(FEnclosureInfo));

  FProcessorInfoIndex := GetSMBiosTableIndex(ProcessorInformation);
  if FProcessorInfoIndex >= 0 then
    Move(Buffer[FProcessorInfoIndex], FProcessorInfo, SizeOf(FProcessorInfo));
end;

end.

Sample project

This console application show how use this unit

{$APPTYPE CONSOLE}

uses
  Classes,
  SysUtils,
  ActiveX,
  ComObj,
  uSMBIOS in 'uSMBIOS.pas';

procedure GetMSSmBios_RawSMBiosTablesInfo;
Var
  SMBios : TSMBios;
  UUID   : Array[0..31] of Char;
  Entry  : TSMBiosTableEntry;
begin
  SMBios:=TSMBios.Create;
  try
    With SMBios do
    begin
        Writeln(Format('%d SMBios tables found',[SMBiosTablesList.Count]));
        Writeln('');

        Writeln('Type Handle Length Index');
        for Entry in SMBiosTablesList do
          Writeln(Format('%3d  %4x   %3d    %4d',[Entry.Header.TableType, Entry.Header.Handle, Entry.Header.Length, Entry.Index]));

      Readln;

      if HasBiosInfo then
      begin
        WriteLn('Bios Information');
        WriteLn('Vendor        '+GetSMBiosString(BiosInfoIndex + BiosInfo.Header.Length, BiosInfo.Vendor));
        WriteLn('Version       '+GetSMBiosString(BiosInfoIndex + BiosInfo.Header.Length, BiosInfo.Version));
        WriteLn('Start Segment '+IntToHex(BiosInfo.StartingSegment,4));
        WriteLn('ReleaseDate   '+GetSMBiosString(BiosInfoIndex + BiosInfo.Header.Length, BiosInfo.ReleaseDate));
        WriteLn(Format('Bios Rom Size %d k',[64*(BiosInfo.BiosRomSize+1)]));
        WriteLn('');
      end;

      if HasSysInfo then
      begin
        WriteLn('System Information');
        WriteLn('Manufacter    '+GetSMBiosString(SysInfoIndex + SysInfo.Header.Length, SysInfo.Manufacturer));
        WriteLn('Product Name  '+GetSMBiosString(SysInfoIndex + SysInfo.Header.Length, SysInfo.ProductName));
        WriteLn('Version       '+GetSMBiosString(SysInfoIndex + SysInfo.Header.Length, SysInfo.Version));
        WriteLn('Serial Number '+GetSMBiosString(SysInfoIndex + SysInfo.Header.Length, SysInfo.SerialNumber));
        BinToHex(@SysInfo.UUID,UUID,SizeOf(SysInfo.UUID));
        WriteLn('UUID          '+UUID);

        WriteLn('');
      end;

      if HasBaseBoardInfo then
      begin
        WriteLn('BaseBoard Information');
        WriteLn('Manufacter    '+GetSMBiosString(BaseBoardInfoIndex + BaseBoardInfo.Header.Length, BaseBoardInfo.Manufacturer));
        WriteLn('Product       '+GetSMBiosString(BaseBoardInfoIndex + BaseBoardInfo.Header.Length, BaseBoardInfo.Product));
        WriteLn('Version       '+GetSMBiosString(BaseBoardInfoIndex + BaseBoardInfo.Header.Length, BaseBoardInfo.Version));
        WriteLn('Serial Number '+GetSMBiosString(BaseBoardInfoIndex + BaseBoardInfo.Header.Length, BaseBoardInfo.SerialNumber));
        WriteLn('');
      end;

      if HasEnclosureInfo then
      begin
        WriteLn('Enclosure Information');
        WriteLn('Manufacter    '+GetSMBiosString(EnclosureInfoIndex + EnclosureInfo.Header.Length, EnclosureInfo.Manufacturer));
        WriteLn('Version       '+GetSMBiosString(EnclosureInfoIndex + EnclosureInfo.Header.Length, EnclosureInfo.Version));
        WriteLn('Serial Number '+GetSMBiosString(EnclosureInfoIndex + EnclosureInfo.Header.Length, EnclosureInfo.SerialNumber));
        WriteLn('Asset Tag Number '+GetSMBiosString(EnclosureInfoIndex + EnclosureInfo.Header.Length, EnclosureInfo.AssetTagNumber));
        WriteLn('');
      end;

      if HasProcessorInfo then
      begin
        WriteLn('Processor Information');
        WriteLn('Socket Designation     '+GetSMBiosString(ProcessorInfoIndex + ProcessorInfo.Header.Length, ProcessorInfo.SocketDesignation));
        WriteLn('Processor Manufacturer '+GetSMBiosString(ProcessorInfoIndex + ProcessorInfo.Header.Length, ProcessorInfo.ProcessorManufacturer));
        WriteLn('Serial Number          '+GetSMBiosString(ProcessorInfoIndex + ProcessorInfo.Header.Length, ProcessorInfo.SerialNumber));
        WriteLn('Asset Tag              '+GetSMBiosString(ProcessorInfoIndex + ProcessorInfo.Header.Length, ProcessorInfo.AssetTag));
        WriteLn('Part Number            '+GetSMBiosString(ProcessorInfoIndex + ProcessorInfo.Header.Length, ProcessorInfo.PartNumber));
        WriteLn('');
      end;
    end;
  finally
   SMBios.Free;
  end;
end;

begin
 try
    CoInitialize(nil);
    try
      GetMSSmBios_RawSMBiosTablesInfo;
    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.

Check these samples images of the console App.

Additional Information

Check the next resources to get more info about the SMBios


14 Comments

Manipulating local/remote files and folders using Delphi and WMI

Some days ago a question in stackoverflow.com was made, about how list the contents of a folder of a remote machine. I answer that question using a WMI approach mentioning the CIM_DataFile and CIM_Directory WMI Classes, these classes  can be used to retrieve information about files, folders and perform many task like copy, rename, delete and  compress.  So today I will show you how you can use these classes form Delphi.

First you must know which in order to access any file or folder  in a remote machine need not be a shared resource, only just must enable the WMI remote access in the machine to access, check these articles for more details about how enable the remote wmi access.

After of enabling the WMI remote access in the client machine you are ready to access the files and folders.

Before to begin

Now some tips which can help you to deal both classes

  1. When you make a WMI query against these classes always you must use filters (Where conditions) to restrict the result of these WMI classes.
  2. Always you must use the Drive field as condition, due to two reasons, first these classes will scan all directories on any available storage device. So this task can take some time. and second to diffentiate for example a folder called Windows located in the Drive C: and in the Drive D:.
  3. The Wmi interprets the \ (Backslash) character as a reserved symbol so you need to escape that character to avoid problems with the WQL sentence.
  4. You can use these classes to find files or folders which match with a criteria, but remember if you not specify the Path property the WMI will scan the entire drive. so try to avoid  sentences like
FWMIService.ExecQuery(Format('SELECT * FROM CIM_DataFile Where Drive="%s" AND Extension="%s"',['C:','jpg']),'WQL',wbemFlagForwardOnly);//this will return all the jpg files in the C Drive

Note :
The code showed in this article uses Late binding to access the WMI, if you want use another way to access the WMI from delphi (like direct COM access or importing th e Microsoft scripting library) take a look to the Delphi WMI Code creator.

Listing Folder and Files

//list the files and folders of a specified Path (non recursive)
procedure  ListFolderContent(Const WbemComputer,WbemUser,WbemPassword,Path:string);
const
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
  WmiPath       : string;
  Drive         : string;
begin;
  //Extract the drive from the Path
  Drive   :=ExtractFileDrive(Path);
  //add a back slash to the end of the folder
  WmiPath :=IncludeTrailingPathDelimiter(Copy(Path,3,Length(Path)));
  //escape the folder name
  WmiPath :=StringReplace(WmiPath,'\','\\',[rfReplaceAll]);

  Writeln('Connecting');
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  //establish the connection
  FWMIService   := FSWbemLocator.ConnectServer(WbemComputer, 'root\CIMV2', WbemUser, WbemPassword);

  Writeln('Files');
  //get the files
  FWbemObjectSet:= FWMIService.ExecQuery(Format('SELECT * FROM CIM_DataFile Where Drive="%s" AND Path="%s"',[Drive,WmiPath]),'WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    Writeln(Format('%s',[FWbemObject.Name]));// String
    FWbemObject:=Unassigned;
  end;

  Writeln('Folders');
  //get the folders
  FWbemObjectSet:= FWMIService.ExecQuery(Format('SELECT * FROM CIM_Directory Where Drive="%s" AND Path="%s"',[Drive,WmiPath]),'WQL',wbemFlagForwardOnly);
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    Writeln(Format('%s',[FWbemObject.Name]));// String
    FWbemObject:=Unassigned;
  end;
end;

How to use

begin
 try
    CoInitialize(nil);
    try
      //ListFolderContent('.','','','C:\data'); //get the content of the folder Data in he local machine
      ListFolderContent('remotemachine','user_name','password','C:\Data');
    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.

Get info about a particular file or folder


This code will list the type, size, creation date, attributes, etc. of any file which you pass as parameter

procedure  GetCIM_DataFileInfo(const FileName:string);
const
  WbemUser            ='';
  WbemPassword        ='';
  WbemComputer        ='localhost';
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer(WbemComputer, 'root\CIMV2', WbemUser, WbemPassword);
  FWbemObject   := FWMIService.Get(Format('CIM_DataFile.Name="%s"',[StringReplace(FileName,'\','\\',[rfReplaceAll])]));
  Writeln(Format('AccessMask               %s',[FWbemObject.AccessMask]));// Uint32
  Writeln(Format('Archive                  %s',[FWbemObject.Archive]));// Boolean
  Writeln(Format('Caption                  %s',[FWbemObject.Caption]));// String
  Writeln(Format('Compressed               %s',[FWbemObject.Compressed]));// Boolean
  Writeln(Format('CompressionMethod        %s',[FWbemObject.CompressionMethod]));// String
  Writeln(Format('CreationClassName        %s',[FWbemObject.CreationClassName]));// String
  Writeln(Format('CreationDate             %s',[FormatDateTime('dd/mm/yyyy hh:nn:ss',WbemTimeToDateTime(FWbemObject.CreationDate))]));// Datetime
  Writeln(Format('CSCreationClassName      %s',[FWbemObject.CSCreationClassName]));// String
  Writeln(Format('CSName                   %s',[FWbemObject.CSName]));// String
  Writeln(Format('Description              %s',[FWbemObject.Description]));// String
  Writeln(Format('Drive                    %s',[FWbemObject.Drive]));// String
  Writeln(Format('EightDotThreeFileName    %s',[FWbemObject.EightDotThreeFileName]));// String
  Writeln(Format('Encrypted                %s',[FWbemObject.Encrypted]));// Boolean
  Writeln(Format('EncryptionMethod         %s',[FWbemObject.EncryptionMethod]));// String
  Writeln(Format('Extension                %s',[FWbemObject.Extension]));// String
  Writeln(Format('FileName                 %s',[FWbemObject.FileName]));// String
  Writeln(Format('FileSize                 %s',[FWbemObject.FileSize]));// Uint64
  Writeln(Format('FileType                 %s',[FWbemObject.FileType]));// String
  Writeln(Format('FSCreationClassName      %s',[FWbemObject.FSCreationClassName]));// String
  Writeln(Format('FSName                   %s',[FWbemObject.FSName]));// String
  Writeln(Format('Hidden                   %s',[FWbemObject.Hidden]));// Boolean
  Writeln(Format('InstallDate              %s',[FormatDateTime('dd/mm/yyyy hh:nn:ss',WbemTimeToDateTime(FWbemObject.InstallDate))]));// Datetime
  Writeln(Format('InUseCount               %s',[FWbemObject.InUseCount]));// Uint64
  Writeln(Format('LastAccessed             %s',[FormatDateTime('dd/mm/yyyy hh:nn:ss',WbemTimeToDateTime(FWbemObject.LastAccessed))]));// Datetime
  Writeln(Format('LastModified             %s',[FormatDateTime('dd/mm/yyyy hh:nn:ss',WbemTimeToDateTime(FWbemObject.LastModified))]));// Datetime
  Writeln(Format('Manufacturer             %s',[FWbemObject.Manufacturer]));// String
  Writeln(Format('Name                     %s',[FWbemObject.Name]));// String
  Writeln(Format('Path                     %s',[FWbemObject.Path]));// String
  Writeln(Format('Readable                 %s',[FWbemObject.Readable]));// Boolean
  Writeln(Format('Status                   %s',[FWbemObject.Status]));// String
  Writeln(Format('System                   %s',[FWbemObject.System]));// Boolean
  Writeln(Format('Version                  %s',[FWbemObject.Version]));// String
  Writeln(Format('Writeable                %s',[FWbemObject.Writeable]));// Boolean
  Writeln('');
end;

In the above code you note two things, first I’m using the SWbemServices.Get method instead SWbemServices.ExecQuery this is because the Get function retrieve a single instance of the wmi object path passed as parameter  (the wmi object path is a string that uniquely identifies a instances of a class). The second
which you must note is the WbemTimeToDateTime  function, this is a helper function to convert the returned WMI datetime values in UTC format to TDateTime.

This is the code of that function, for more info check the documentation about the WbemScripting.SWbemDateTime object.

function WbemTimeToDateTime(const V : OleVariant): TDateTime;
var
  Dt : OleVariant;
begin
  Result:=0;
  if VarIsNull(V) then exit;
  Dt:=CreateOleObject('WbemScripting.SWbemDateTime');
  Dt.Value := V;
  Result:=Dt.GetVarDate;
end;

This code will list the size, creation date, atributes, etc. of any folder which you pass as parameter

procedure  GetCIM_DirectoryInfo(const FolderName:string);
const
  WbemUser            ='';
  WbemPassword        ='';
  WbemComputer        ='localhost';
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer(WbemComputer, 'root\CIMV2', WbemUser, WbemPassword);
  FWbemObject   := FWMIService.Get(Format('CIM_Directory.Name="%s"',[StringReplace(FolderName,'\','\\',[rfReplaceAll])]));
  Writeln(Format('AccessMask               %s',[FWbemObject.AccessMask]));// Uint32
  Writeln(Format('Archive                  %s',[FWbemObject.Archive]));// Boolean
  Writeln(Format('Caption                  %s',[FWbemObject.Caption]));// String
  Writeln(Format('Compressed               %s',[FWbemObject.Compressed]));// Boolean
  Writeln(Format('CompressionMethod        %s',[FWbemObject.CompressionMethod]));// String
  Writeln(Format('CreationClassName        %s',[FWbemObject.CreationClassName]));// String
  Writeln(Format('CreationDate             %s',[FormatDateTime('dd/mm/yyyy hh:nn:ss',WbemTimeToDateTime(FWbemObject.CreationDate))]));// Datetime
  Writeln(Format('CSCreationClassName      %s',[FWbemObject.CSCreationClassName]));// String
  Writeln(Format('CSName                   %s',[FWbemObject.CSName]));// String
  Writeln(Format('Description              %s',[FWbemObject.Description]));// String
  Writeln(Format('Drive                    %s',[FWbemObject.Drive]));// String
  Writeln(Format('EightDotThreeFileName    %s',[FWbemObject.EightDotThreeFileName]));// String
  Writeln(Format('Encrypted                %s',[FWbemObject.Encrypted]));// Boolean
  Writeln(Format('EncryptionMethod         %s',[FWbemObject.EncryptionMethod]));// String
  Writeln(Format('Extension                %s',[FWbemObject.Extension]));// String
  Writeln(Format('FileName                 %s',[FWbemObject.FileName]));// String
  Writeln(Format('FileSize                 %s',[FWbemObject.FileSize]));// Uint64
  Writeln(Format('FileType                 %s',[FWbemObject.FileType]));// String
  Writeln(Format('FSCreationClassName      %s',[FWbemObject.FSCreationClassName]));// String
  Writeln(Format('FSName                   %s',[FWbemObject.FSName]));// String
  Writeln(Format('Hidden                   %s',[FWbemObject.Hidden]));// Boolean
  Writeln(Format('InstallDate              %s',[FormatDateTime('dd/mm/yyyy hh:nn:ss',WbemTimeToDateTime(FWbemObject.InstallDate))]));// Datetime
  Writeln(Format('InUseCount               %s',[FWbemObject.InUseCount]));// Uint64
  Writeln(Format('LastAccessed             %s',[FormatDateTime('dd/mm/yyyy hh:nn:ss',WbemTimeToDateTime(FWbemObject.LastAccessed))]));// Datetime
  Writeln(Format('LastModified             %s',[FormatDateTime('dd/mm/yyyy hh:nn:ss',WbemTimeToDateTime(FWbemObject.LastModified))]));// Datetime
  Writeln(Format('Name                     %s',[FWbemObject.Name]));// String
  Writeln(Format('Path                     %s',[FWbemObject.Path]));// String
  Writeln(Format('Readable                 %s',[FWbemObject.Readable]));// Boolean
  Writeln(Format('Status                   %s',[FWbemObject.Status]));// String
  Writeln(Format('System                   %s',[FWbemObject.System]));// Boolean
  Writeln(Format('Writeable                %s',[FWbemObject.Writeable]));// Boolean
  Writeln('');
end;

Compress a File or Folder using the NTFS compression

function  CompressFile(const FileName:string):integer;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObject   := FWMIService.Get(Format('CIM_DataFile.Name="%s"',[StringReplace(FileName,'\','\\',[rfReplaceAll])]));
  Result:=FWbemObject.Compress();
end;
function  CompressFolder(const FolderName:string;Recursive:Boolean):integer;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
  StopFileName  : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObject   := FWMIService.Get(Format('CIM_Directory.Name="%s"',[StringReplace(FolderName,'\','\\',[rfReplaceAll])]));
  if Recursive then
   Result:=FWbemObject.CompressEx(StopFileName, Null, Recursive)
  else
   Result:=FWbemObject.Compress();
end;

UnCompress a File or Folder using the NTFS compression

function  UnCompressFile(const FileName:string):integer;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObject   := FWMIService.Get(Format('CIM_DataFile.Name="%s"',[StringReplace(FileName,'\','\\',[rfReplaceAll])]));
  Result:=FWbemObject.UnCompress();
end;
function  UnCompressFolder(const FolderName:string;Recursive:Boolean):integer;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
  StopFileName  : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObject   := FWMIService.Get(Format('CIM_Directory.Name="%s"',[StringReplace(FolderName,'\','\\',[rfReplaceAll])]));
  if Recursive then
   Result:=FWbemObject.UnCompressEx(StopFileName, Variants.Null, Recursive)
  else
   Result:=FWbemObject.UnCompress();
end;

Copy a single File or Folder

function  CopyFile(const SourceFileName,DestFileName:string):integer;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObject   := FWMIService.Get(Format('CIM_DataFile.Name="%s"',[StringReplace(SourceFileName,'\','\\',[rfReplaceAll])]));
  Result:=FWbemObject.Copy(DestFileName);
end;
function  CopyFolder(const SourceFolder,DestFolder:string;Recursive:Boolean):integer;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
  StopFileName  : OleVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObject   := FWMIService.Get(Format('CIM_Directory.Name="%s"',[StringReplace(SourceFolder,'\','\\',[rfReplaceAll])]));
  if Recursive then
    Result:=FWbemObject.CopyEx(DestFolder,StopFileName, Variants.Null, Recursive)
  else
    Result:=FWbemObject.Copy(DestFolder);
end;

Delete a File or Folder

function  DeleteFile(const FileName:string):integer;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObject   := FWMIService.Get(Format('CIM_DataFile.Name="%s"',[StringReplace(FileName,'\','\\',[rfReplaceAll])]));
  Result:=FWbemObject.Delete();
end;
//remove all the contents of the folder recursivily
function  DeleteFolder(const FolderName:string):integer;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObject   := FWMIService.Get(Format('CIM_Directory.Name="%s"',[StringReplace(FolderName,'\','\\',[rfReplaceAll])]));
  Result:=FWbemObject.Delete();
end;

Rename a File or Folder

function RenameFile(const OldName, NewName: string): Integer;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObject   := FWMIService.Get(Format('CIM_DataFile.Name="%s"',[StringReplace(OldName,'\','\\',[rfReplaceAll])]));
  Result:=FWbemObject.Rename(NewName);
end;
function RenameFolder(const OldName, NewName: string): Integer;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObject   := FWMIService.Get(Format('CIM_Directory.Name="%s"',[StringReplace(OldName,'\','\\',[rfReplaceAll])]));
  Result:=FWbemObject.Rename(NewName);
end;

Getting the permissions over a CIM_DataFile or CIM_Directory object

In order to get whether the caller has the permissions on the CIM_DataFile or CIM_Directory object you must use the GetEffectivePermission function with these flags

Value (Dec/Hex) Meaning
FILE_READ_DATA (file)FILE_LIST_DIRECTORY (directory)
1 (0x1)
Grants the right to read data from the file. For a directory, this value grants the right to list the contents of the directory.
FILE_WRITE_DATA (file)FILE_ADD_FILE (directory)
2 (0x2)
Grants the right to write data to the file. For a directory, this value grants the right to create a file in the directory.
FILE_APPEND_DATA (file)FILE_ADD_SUBDIRECTORY (directory)
4 (0x4)
Grants the right to append data to the file. For a directory, this value grants the right to create a subdirectory.
FILE_READ_EA
8 (0x8)
Grants the right to read extended attributes.
FILE_WRITE_EA
16 (0x10)
Grants the right to write extended attributes.
FILE_EXECUTE (file)FILE_TRAVERSE (directory)
32 (0x20)
Grants the right to execute a file. For a directory, the directory can be traversed.
FILE_DELETE_CHILD (directory)
64 (0x40)
Grants the right to delete a directory and all the files it contains, even if the files are read-only.
FILE_READ_ATTRIBUTES
128 (0x80)
Grants the right to read file attributes.
FILE_WRITE_ATTRIBUTES
256 (0x100)
Grants the right to change file attributes.
DELETE
65536 (0x10000)
Grants delete access.
READ_CONTROL
131072 (0x20000)
Grants read access to the security descriptor and owner.
WRITE_DAC
262144 (0x40000)
Grants write access to the discretionary ACL.
WRITE_OWNER
524288 (0x80000)
Assigns the write owner.
SYNCHRONIZE
1048576 (0x100000)
Synchronizes access and allows a process to wait for an object to enter the signaled state.
function GetEffectivePermission(const FileName:string;Flags:integer):Boolean;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObject   : OLEVariant;
begin;
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  FWbemObject   := FWMIService.Get(Format('CIM_DataFile.Name="%s"',[StringReplace(FileName,'\','\\',[rfReplaceAll])]));
  Result:=FWbemObject.GetEffectivePermission(Flags);
end;

And use like this

GetEffectivePermission('C:\FooFolder\Foo_Filename.ext',FILE_READ_DATA or FILE_READ_ATTRIBUTES);

Getting the Status of a task

The functions Compress, UnCompress, Copy, Rename and Delete return a Result code which can be translated to a message using this function

function GetResultMessage(ResultCode:Integer) : string;
begin
  case ResultCode of
     0 : Result:='Success';
     2 : Result:='Access denied';
     8 : Result:='Unspecified failure';
     9 : Result:='Invalid object';
    10 : Result:='Object already exists';
    11 : Result:='File system not NTFS';
    12 : Result:='Platform not Windows NT or Windows 2000';
    13 : Result:='Drive not the same';
    14 : Result:='Directory not empty';
    15 : Result:='Sharing violation';
    16 : Result:='Invalid start file';
    17 : Result:='Privilege not held';
    21 : Result:='Invalid parameter'
  else
    Result := 'Unknown';
  end;
end;

Demo Application

Check this demo application which can list all the files and folders in a remote or local machine only using the WMI

checkout the full source code on Github.

 


5 Comments

Two ways to get the command line of another process using delphi

Note : for a updated version of the code check the Github repo.


Today I will show you how you can retrieve the Command line parameters of an external application from Delphi using the WinApi and the WMI. In order to understand how the Command line parameters are stored and treated by the system, I recommend which you read this article from  Raymond Chen .

The WinApi way

In order to get the command line from an external process using the WinAPI, you must access to the PEB (Process Environment Block) of the application. To get the PEB you can use the NtQueryInformationProcess function

NTSTATUS WINAPI NtQueryInformationProcess(
  __in       HANDLE ProcessHandle,
  __in       PROCESSINFOCLASS ProcessInformationClass,
  __out      PVOID ProcessInformation,
  __in       ULONG ProcessInformationLength,
  __out_opt  PULONG ReturnLength
);

 

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

Passing the ProcessBasicInformation value in the ProcessInformationClass parameter and a buffer to hold the PROCESS_BASIC_INFORMATION returned in the ProcessInformation.

This is the official (MSDN) definition for the PROCESS_BASIC_INFORMATION structure

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

And this a more friendly delphi translation of this structure using the NTinterlnals.net site

  PROCESS_BASIC_INFORMATION = packed record
    ExitStatus: DWORD;
    PebBaseAddress: Pointer;
    AffinityMask: DWORD;
    BasePriority: DWORD;
    UniqueProcessId: DWORD;
    InheritedUniquePID:DWORD;
  end;

The key field in this structure is PebBaseAddress, which stores the address of the PEB. from this point now you must digging inside of the PEB structure again

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 retrieve the value of the ProcessParameters field which is a pointer to a RTL_USER_PROCESS_PARAMETERS structure

typedef struct _RTL_USER_PROCESS_PARAMETERS {
  BYTE           Reserved1[16];
  PVOID          Reserved2[10];
  UNICODE_STRING ImagePathName;
  UNICODE_STRING CommandLine;
} RTL_USER_PROCESS_PARAMETERS, *PRTL_USER_PROCESS_PARAMETERS;

Finally you can note which the CommandLine field stores the info which are looking for.

The WinAPI Delphi Code

This is the Delphi source which retrieves the Command line parameters from an external application
Notes :

  1. the next code uses hard-coded offsets to read specific locations of the PEB to avoid the declaration the full structures required (feel free to declare these structures and avoid the offsets).
  2. this code only works for 32 bits process because the structure of the PEB differs from 32 to 64 processes.
  3. to gain access to the processes owned by the system the code set the  SeDebugPrivilege token before to use the OpenProcess function.
//Author Rodrigo Ruz V.
//2011-07-20
{$APPTYPE CONSOLE}
uses
  SysUtils,
  Windows;

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

  PROCESS_BASIC_INFORMATION = packed record
    ExitStatus: DWORD;
    PebBaseAddress: Pointer;
    AffinityMask: DWORD;
    BasePriority: DWORD;
    UniqueProcessId: DWORD;
    InheritedUniquePID:DWORD;
  end;

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

function GetCommandLineFromPid(PID: THandle): string;
const
  STATUS_SUCCESS             = $00000000;
  SE_DEBUG_NAME              = 'SeDebugPrivilege';
  OffsetProcessParametersx32 = $10;//16
  OffsetCommandLinex32       = $40;//64
var
  ProcessHandle        : THandle;
  rtlUserProcAddress   : Pointer;
  CommandLine          : UNICODE_STRING;
  CommandLineContents  : WideString;
  ProcessBasicInfo     : PROCESS_BASIC_INFORMATION;
  ReturnLength         : Cardinal;
  TokenHandle          : THandle;
  lpLuid               : TOKEN_PRIVILEGES;
  OldlpLuid            : TOKEN_PRIVILEGES;
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, PID);
      if ProcessHandle=0 then RaiseLastOSError
      else
      try
        // get the PROCESS_BASIC_INFORMATION to access to the PEB Address
        if (NtQueryInformationProcess(ProcessHandle,0{=&gt;ProcessBasicInformation},@ProcessBasicInfo, sizeof(ProcessBasicInfo), @ReturnLength)=STATUS_SUCCESS) and (ReturnLength=SizeOf(ProcessBasicInfo)) then
        begin
          //get the address of the RTL_USER_PROCESS_PARAMETERS struture
          if not ReadProcessMemory(ProcessHandle, Pointer(Longint(ProcessBasicInfo.PEBBaseAddress) + OffsetProcessParametersx32), @rtlUserProcAddress, sizeof(Pointer), ReturnLength) then
            RaiseLastOSError
          else
          if ReadProcessMemory(ProcessHandle, Pointer(Longint(rtlUserProcAddress) + OffsetCommandLinex32), @CommandLine, sizeof(CommandLine), ReturnLength) then
          begin
            SetLength(CommandLineContents, CommandLine.length);
            //get the CommandLine field
            if ReadProcessMemory(ProcessHandle, CommandLine.Buffer, @CommandLineContents[1], CommandLine.Length, ReturnLength) then
             Result := WideCharLenToString(PWideChar(CommandLineContents), CommandLine.length div 2)
            else
            RaiseLastOSError;
          end;
        end
        else
        RaiseLastOSError;
      finally
        CloseHandle(ProcessHandle);
      end;
    finally
      CloseHandle(TokenHandle);
    end;
  end
  else
  RaiseLastOSError;
end;

begin
 try
   Writeln(GetCommandLineFromPid(5440));
 except
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
 Readln;
end.

The WMI way

The WMI provides a very reliable and easy way to access the Command line parameters from an external process, all you must to do is use the Win32_Process wmi class and look in the CommandLine property.

The WMI Delphi Code

Notes

  1. The next code can retrieve the command line for 32 and 64 bits processes.
  2. The code uses Late binding to access the WMI, if you want use another way to access the WMI from Delphi (like direct COM access or importing th e Microsoft scripting library) take a look to the Delphi WMI Code creator.
  3. You can change the credentials of the ConnectServer function to access to the command line parameters of a remote machine process.
{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils,
  ActiveX,
  Variants,
  ComObj;

function  GetCommandLineFromPid(ProcessId:DWORD): string;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
begin;
  Result:='';
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  FWMIService   := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  //if the pid not exist a EOleException exception will be raised with the code $80041002 - Object Not Found
  FWbemObjectSet:= FWMIService.Get(Format('Win32_Process.Handle="%d"',[ProcessId]));
  Result:=FWbemObjectSet.CommandLine;
end;

begin
 try
    CoInitialize(nil);
    try
     Writeln(GetCommandLineFromPid(5452));
    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.


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.


6 Comments

Using the Google Safe Browsing API from Delphi

The Google Safe Browsing API is a service that enables applications to check URLs against the Google’s lists of suspected phishing and malware pages. Exist two types of APIs for using the Safe Browsing service, Safe Browsing API v2 and Safe Browsing Lookup API in this article I will show how use the Safe Browsing Lookup API from a Delphi application.

The Safe Browsing Lookup API is designed to provide a simple interface through HTTP GET or POST request and get the state of the URL(s) directly from the server.

Like most of the services provided by Google you need to request an API key. In order to obtain an API key you must log in with your existing Google account and sign up for the API at http://www.google.com/safebrowsing/key_signup.html

Using the GET Method

The Get method  allow to the client only lookup one URL per request. To use the GET method you must make a request to this URL

https://sb-ssl.google.com/safebrowsing/api/lookup?client=CLIENT&apikey=APIKEY&appver=APPVER&pver=PVER&url=URL

Parameters

  • The client parameter indicates the type of client, it could be any name of the client’s choice.
  • The apikey parameter indicates the API key.
  • The appver parameter indicates the version of the client.
  • The pver parameter indicates the protocol version that the client supports. Currently this should be “3.0”. The format is “major.minor”. If we update the protocol, we will make sure that minor revisions are always compatible; however major revision will be incompatible and the server MAY NOT be able to cope with an older protocol.
  • The url parameter indicates the url the client wants to lookup. It must be a valid URL (non ASCII characters must be in UTF-8) and needs to be encoded properly to avoid confusion. For example, if the url contains ‘&’, it could be interpreted as the separator of the CGI parameters. We require the API users to use the percent encoding for the set of “reserved characters”, which is defined in RFC 3986 . A summary of the percent encoding can be found here.

Check this Sample Url

https://sb-ssl.google.com/safebrowsing/api/lookup?client=mydemoapp&<strong>apikey</strong>=1234567890&appver=1.0.1&pver=3.0&url=http%3A%2F%2Fwww.google.com%2F

In this case the values passed are

client = mydemoapp
apikey = 1234567890
appver = 1.0.1
pver   = 3.0
url    = http://www.google.com

Response

The service returns the following HTTP response codes for the GET method

  • 200: The queried URL is either phishing, malware or both, see the response body for the specific type.
  • 204: The requested URL is legitimate, no response body returned.
  • 400: Bad Request — The HTTP request was not correctly formed.
  • 401: Not Authorized — The apikey is not authorized
  • 503: Service Unavailable .

Additionally  the server will include the actual type of URL in the response body when the queried URL matches either the phishing or malware lists, so the body will contain one of these values
“phishing” | “malware” | “phishing,malware"

Delphi Code for the GET Request

The next source uses the Wininet functions to make the GET request, feel free to use another components like Indy or synapse to accomplish this task.

{$APPTYPE CONSOLE}
uses
  Classes,
  Windows,
  WinInet,
  SysUtils;
const
  sUserAgent = 'Mozilla/5.001 (windows; U; NT4.0; en-US; rv:1.0) Gecko/25250101';
  //¡¡¡¡¡¡¡¡¡¡Please be nice and use your own API key, get a key from here http://code.google.com/apis/safebrowsing/key_signup.html ¡¡¡¡¡¡¡¡¡¡¡¡¡¡¡¡¡¡¡
  sApiKey    = 'ABQIAAAAzY4CKjsBFYV4Rxx0ZQaKlxQL2a1oqOk9I7UVXAZVtWa6uSA2XA';
  sServer    = 'sb-ssl.google.com';
  sGetSafeBrowsing   = '/safebrowsing/api/lookup?client=delphi&apikey=%s&appver=1.5.2&pver=3.0&url=%s';

//this function translate a WinInet Error Code to a description of the error.
function GetWinInetError(ErrorCode:Cardinal): string;
const
   winetdll = 'wininet.dll';
var
  Len: Integer;
  Buffer: PChar;
begin
  Len := FormatMessage(
  FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_FROM_SYSTEM or
  FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_IGNORE_INSERTS or  FORMAT_MESSAGE_ARGUMENT_ARRAY,
  Pointer(GetModuleHandle(winetdll)), ErrorCode, 0, @Buffer, SizeOf(Buffer), nil);
  try
    while (Len > 0) and {$IFDEF UNICODE}(CharInSet(Buffer[Len - 1], [#0..#32, '.'])) {$ELSE}(Buffer[Len - 1] in [#0..#32, '.']) {$ENDIF} do Dec(Len);
    SetString(Result, Buffer, Len);
  finally
    LocalFree(HLOCAL(Buffer));
  end;
end;

//make a GET request using the WinInet functions
function Https_Get(const ServerName,Resource : string;Var Response:AnsiString): Integer;
const
  BufferSize=1024*64;
var
  hInet    : HINTERNET;
  hConnect : HINTERNET;
  hRequest : HINTERNET;
  ErrorCode : Integer;
  lpvBuffer : PAnsiChar;
  lpdwBufferLength: DWORD;
  lpdwReserved    : DWORD;
  dwBytesRead     : DWORD;
  lpdwNumberOfBytesAvailable: DWORD;
begin
  Result  :=0;
  Response:='';
  hInet := InternetOpen(PChar(sUserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if hInet=nil then
  begin
    ErrorCode:=GetLastError;
    raise Exception.Create(Format('InternetOpen Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
  end;

  try
    hConnect := InternetConnect(hInet, PChar(ServerName), INTERNET_DEFAULT_HTTPS_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
    if hConnect=nil then
    begin
      ErrorCode:=GetLastError;
      raise Exception.Create(Format('InternetConnect Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
    end;

    try
      //make the request
      hRequest := HttpOpenRequest(hConnect, 'GET', PChar(Resource), HTTP_VERSION, '', nil, INTERNET_FLAG_SECURE, 0);
      if hRequest=nil then
      begin
        ErrorCode:=GetLastError;
        raise Exception.Create(Format('HttpOpenRequest Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
      end;

      try
        //send the GET request
        if not HttpSendRequest(hRequest, nil, 0, nil, 0) then
        begin
          ErrorCode:=GetLastError;
          raise Exception.Create(Format('HttpSendRequest Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
        end;

          lpdwBufferLength:=SizeOf(Result);
          lpdwReserved    :=0;
          //get the status code
          if not HttpQueryInfo(hRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, @Result, lpdwBufferLength, lpdwReserved) then
          begin
            ErrorCode:=GetLastError;
            raise Exception.Create(Format('HttpQueryInfo Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
          end;

         if Result=200 then //read the body response in case which the status code is 200
          if InternetQueryDataAvailable(hRequest, lpdwNumberOfBytesAvailable, 0, 0) then
          begin
            GetMem(lpvBuffer,lpdwBufferLength);
            try
              SetLength(Response,lpdwNumberOfBytesAvailable);
              InternetReadFile(hRequest, @Response[1], lpdwNumberOfBytesAvailable, dwBytesRead);
            finally
              FreeMem(lpvBuffer);
            end;
          end
          else
          begin
            ErrorCode:=GetLastError;
            raise Exception.Create(Format('InternetQueryDataAvailable Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
          end;

      finally
        InternetCloseHandle(hRequest);
      end;
    finally
      InternetCloseHandle(hConnect);
    end;
  finally
    InternetCloseHandle(hInet);
  end;
end;

//encode a Url
function URLEncode(const Url: string): string;
var
  i: Integer;
begin
  Result := '';
  for i := 1 to Length(Url) do
  begin
    case Url[i] of
      'A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.':
        Result := Result + Url[i];
    else
        Result := Result + '%' + IntToHex(Ord(Url[i]), 2);
    end;
  end;
end;

//Send The GET request and process the returned body
Procedure TestGet(const AUrl : string);
var
 Response     : AnsiString;
 ResponseCode : Integer;
begin
   ResponseCode:=Https_Get(sServer,Format(sGetSafeBrowsing,[sApiKey,URLEncode(AUrl)]), Response);
   case ResponseCode of
     200: Writeln(Format('The queried URL (%s) is %s',[AUrl,Response]));
     204: Writeln(Format('The queried URL (%s) is %s',[AUrl,'legitimate']));
     400: Writeln('Bad Request — The HTTP request was not correctly formed.');
     401: Writeln('Not Authorized — The apikey is not authorized');
     503: Writeln('Service Unavailable — The server cannot handle the request.');
   else
         Writeln('Unknow response');
   end;
end;

begin
  try
     //Now check some urls.
     TestGet('http://malware.testing.google.test/testing/malware/');
     TestGet('orgsite.info');
     TestGet('http://www.google.com');
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.

This will return

The queried URL (http://malware.testing.google.test/testing/malware/) is malware
The queried URL (orgsite.info) is malware
The queried URL (http://www.google.com) is legitimate

Using the POST Method

The post request is more powerful because the client can also look up a set of URLs (up to 500) through HTTP POST request. To use the POST method you must make a request to this URL

https://sb-ssl.google.com/safebrowsing/api/lookup?client=CLIENT&apikey=APIKEY&appver=APPVER&pver=PVER

Parameters

  • The client parameter indicates the type of client, it could be any name of the client’s choice.
  • The apikey parameter indicates the API key.
  • The appver parameter indicates the version of the client.
  • The pver parameter indicates the protocol version that the client supports.

Check this Sample Url

https://sb-ssl.google.com/safebrowsing/api/lookup?client=mydemoapp&<strong>apikey</strong>=1234567890&appver=1.0.1&pver=3.0

Request Body

The client specifies the queried URLs in the POST request body using the following format:
POST_REQ_BODY = NUM LF URL (LF URL)*
NUM = (DIGIT)+
URL = url string following the RFC 1738

The request’s body contains several lines separated by LF. The first line is a number indicating how many URLs are included in the body. The next several lines are URLs to be looked up. Each line contains one URL and the client must specify at least one URL in the body.

check this sample

2
http://www.google.com/
http://malware.testing.google.test/testing/malware/

Response

The server generates the following HTTP response codes for the POST request:

  • 200: AT LEAST ONE of the queried URLs are matched in either the phishing or malware lists, the actual results are returned through the response body
  • 204: NONE of the queried URLs matched the phishing or malware lists, no response body returned
  • 400: Bad Request — The HTTP request was not correctly formed
  • 401: Not Authorized.
  • 503: Service Unavailable.

Body

In the POST request, the server will return a list of  URLs queried in the response body when at least one of the queried URLs matches in the suspected phishing or malware lists.
POST_RESP_BODY = VERDICT (LF VERDICT)*
VERDICT = “phishing” | “malware” | “phishing,malware” | “ok”

The type has the same meaning as in the GET response body except that some of the URLs may be legitimate (recall that the server returns empty content only when none of the queried URLs matches the phishing or malware lists). In this case, we return “ok” for the non-matching URLs. The results are separated by the LF. There is a one-on-one mapping between the results in the response body and the queried URLs in the request body. For example, assume there are 10 URLs specified in the request body, the server will return exactly 10 results with the original order. That is, the first line corresponds to the result of the first queried URL, the second line corresponds to the result of the second queried URL, and so on.

Delphi Code for the POST Request

{$APPTYPE CONSOLE}
uses
  Classes,
  Windows,
  WinInet,
  SysUtils;

const
  sUserAgent = 'Mozilla/5.001 (windows; U; NT4.0; en-US; rv:1.0) Gecko/25250101';
  //¡¡¡¡¡¡¡¡¡¡Please be nice and use your own API key, get a key from here http://code.google.com/apis/safebrowsing/key_signup.html ¡¡¡¡¡¡¡¡¡¡¡¡¡¡¡¡¡¡¡
  sApiKey    = 'ABQIAAAAzY4CKjsBFYV4Rxx0ZQaKlxQL2a1oqOk9I7UVXAZVtWa6uSA2XA';
  sServer    = 'sb-ssl.google.com';
  sPostSafeBrowsing  = '/safebrowsing/api/lookup?client=delphi&apikey=%s&appver=1.5.2&pver=3.0';

function GetWinInetError(ErrorCode:Cardinal): string;
const
   winetdll = 'wininet.dll';
var
  Len: Integer;
  Buffer: PChar;
begin
  Len := FormatMessage(
  FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_FROM_SYSTEM or
  FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_IGNORE_INSERTS or  FORMAT_MESSAGE_ARGUMENT_ARRAY,
  Pointer(GetModuleHandle(winetdll)), ErrorCode, 0, @Buffer, SizeOf(Buffer), nil);
  try
    while (Len > 0) and {$IFDEF UNICODE}(CharInSet(Buffer[Len - 1], [#0..#32, '.'])) {$ELSE}(Buffer[Len - 1] in [#0..#32, '.']) {$ENDIF} do Dec(Len);
    SetString(Result, Buffer, Len);
  finally
    LocalFree(HLOCAL(Buffer));
  end;
end;

function Https_Post(const ServerName,Resource: String;const PostData : AnsiString;Var Response:AnsiString): Integer;
const
  BufferSize=1024*64;
var
  hInet    : HINTERNET;
  hConnect : HINTERNET;
  hRequest : HINTERNET;
  ErrorCode : Integer;
  lpdwBufferLength: DWORD;
  lpdwReserved    : DWORD;
  dwBytesRead     : DWORD;
  lpdwNumberOfBytesAvailable: DWORD;
begin
  Result  :=0;
  Response:='';
  hInet := InternetOpen(PChar(sUserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if hInet=nil then
  begin
    ErrorCode:=GetLastError;
    raise Exception.Create(Format('InternetOpen Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
  end;

  try
    hConnect := InternetConnect(hInet, PChar(ServerName), INTERNET_DEFAULT_HTTPS_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
    if hConnect=nil then
    begin
      ErrorCode:=GetLastError;
      raise Exception.Create(Format('InternetConnect Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
    end;

    try
      hRequest := HttpOpenRequest(hConnect, 'POST', PChar(Resource), HTTP_VERSION, '', nil, INTERNET_FLAG_SECURE, 0);
      if hRequest=nil then
      begin
        ErrorCode:=GetLastError;
        raise Exception.Create(Format('HttpOpenRequest Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
      end;

      try
        //send the post request
        if not HTTPSendRequest(hRequest, nil, 0, @PostData[1], Length(PostData)) then
        begin
          ErrorCode:=GetLastError;
          raise Exception.Create(Format('HttpSendRequest Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
        end;

          lpdwBufferLength:=SizeOf(Result);
          lpdwReserved    :=0;
          //get the response code
          if not HttpQueryInfo(hRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, @Result, lpdwBufferLength, lpdwReserved) then
          begin
            ErrorCode:=GetLastError;
            raise Exception.Create(Format('HttpQueryInfo Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
          end;

         //if the response code =200 then get the body
         if Result=200 then
          if InternetQueryDataAvailable(hRequest, lpdwNumberOfBytesAvailable, 0, 0) then
          begin
            SetLength(Response,lpdwNumberOfBytesAvailable);
            InternetReadFile(hRequest, @Response[1], lpdwNumberOfBytesAvailable, dwBytesRead);
          end
          else
          begin
            ErrorCode:=GetLastError;
            raise Exception.Create(Format('InternetQueryDataAvailable Error %d Description %s',[ErrorCode,GetWinInetError(ErrorCode)]));
          end;

      finally
        InternetCloseHandle(hRequest);
      end;
    finally
      InternetCloseHandle(hConnect);
    end;
  finally
    InternetCloseHandle(hInet);
  end;
end;

function URLEncode(const Url: string): string;
var
  i: Integer;
begin
  Result := '';
  for i := 1 to Length(Url) do
  begin
    case Url[i] of
      'A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.':
        Result := Result + Url[i];
    else
        Result := Result + '%' + IntToHex(Ord(Url[i]), 2);
    end;
  end;
end;

Procedure TestPost(const UrlList : Array of AnsiString);
var
 Response     : AnsiString;
 ResponseCode : Integer;
 Data         : AnsiString;
 i            : integer;
 LstUrl       : TStringList;
begin
   //create the body request with the url to lookup
   Data:=AnsiString(IntToStr(Length(UrlList)))+#10;
   for i:= low(UrlList) to high(UrlList) do
     Data:=Data+UrlList[i]+#10;

   //make the post request
   ResponseCode:=Https_Post(sServer,Format(sPostSafeBrowsing,[sApiKey]), Data, Response);

   //process the response
   case ResponseCode of
     200:
          begin
             LstUrl:=TStringList.Create;
             try
               LstUrl.Text:=string(Response);
                for i:=0 to  LstUrl.Count-1  do
                 Writeln(Format('The queried URL (%s) is %s',[UrlList[i],LstUrl[i]]));

             finally
               LstUrl.Free;
             end;
          end;
     204: Writeln('NONE of the queried URLs matched the phishing or malware lists, no response body returned');
     400: Writeln('Bad Request — The HTTP request was not correctly formed.');
     401: Writeln('Not Authorized — The apikey is not authorized');
     503: Writeln('Service Unavailable — The server cannot handle the request.');
   else
         Writeln(Format('Unknow response Code (%d)',[ResponseCode]));
   end;
end;

begin
  try
     //check these three urls at once
     TestPost(['orgsite.info','http://www.google.com','http://malware.testing.google.test/testing/malware/']);
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.

finally the result will be

The queried URL (orgsite.info) is malware
The queried URL (http://www.google.com) is ok
The queried URL (http://malware.testing.google.test/testing/malware/) is malware


6 Comments

Delphi IDE Theme Editor – Now supports Lazarus

The Delphi IDE Theme Editor now supports the Lazarus IDE , so you can use any of the themes included in the installer or make your own theme. you can add the themes to the Lazarus IDE coping the generated themes (check  the Themes Lazarus folder in the installation path or download  the included Lazarus themes from here) to the primary_conf_path/userschemes/   folder (example in windows vista the folder is C:\Users\<Windows User>\AppData\Local\lazarus\userschemes) or let to the tool apply the current theme to Lazarus IDE.

For more information about the Lazarus color schemes check these articles

ScreenShots


1 Comment

Delphi Preview Handler – source code published in google code

Update : this project now is hosted on Github.

A few hours ago I  published in the google code site the code of the Delphi Preview Handler project, under the Mozilla Public License 1.1 , now you can browse in the code and make your suggestions and report bugs using the issue page of the project. I also want to thank to Uwe Raabe by allow me use part of his work in this article to rewrite some parts of the preview handler.


22 Comments

Using the Google Maps API V3 from Delphi – Part III Getting the latitude and longitude of a mouse click

In this post I will show, how you can interact with a google map embedded in a TWebbrowser component in order to get the location ( latitude and longitude) of  a point when you click in the map.

JavaScript

To get the location of the mouse when you make a click in the map you must add a  Google maps Event Listener, passing a function to process the event, the values of the current location are retrieved in the event.latLng variable , the next step is store the values returned in a hidden field element to after get these values from Delphi.

Check this sample JavaScript snippet which create an event listener and store the values in the LatValue and LngValue fields.

    google.maps.event.addListener(map, "click",
         function(event)
           {
            document.getElementById("LatValue").value = event.latLng.lat();
            document.getElementById("LngValue").value = event.latLng.lng();
            PutMarker(document.getElementById("LatValue").value, document.getElementById("LngValue").value,"")
           }
   );

This is the PutMarker function which creates a marker in the current location

function PutMarker(Lat, Lang, Msg)
{
 var latlng = new google.maps.LatLng(Lat,Lang);
 var marker = new google.maps.Marker({
     position: latlng,
     map: map,
     title: Msg+" ("+Lat+","+Lang+")"
  });

   //put the created marker in an array
   markersArray.push(marker);

   //compute the index to associate an image to the marker
   index= (markersArray.length % 10);
   if (index==0) { index=10 }
   icon = "http://www.google.com/mapfiles/kml/paddle/"+index+"-lv.png";
   marker.setIcon(icon);
 }

And this is the code to create the 2 input hidden fields in the html page to store the values returned by the Event listener

<body onload="initialize()">
  <div id="map_canvas" style="width:100%; height:100%"></div>
  <div id="latlong">
  <input id="<span class=" type="hidden" />LatValue" >
  <input id="<span class=" type="hidden" />LngValue" >
  </div>
</body>

Delphi

Now from the Delphi side, you must detect the click event in the TWebBrowser component and then read the values stored in the hidden fields. Exists several ways to detect the click in the TWebBrowser, in this case I will use the OnCommandStateChange event.

Check this code which detect the click event and then read the values stored in the hidden fields.

procedure TForm1.WebBrowser1CommandStateChange(ASender: TObject;  Command: Integer; Enable: WordBool);
var
  ADocument : IHTMLDocument2;
  ABody     : IHTMLElement2;
  Lat : string;
  Lng : string;

      //get the value from a field
      function GetIdValue(const Id : string):string;
      var
        Tag      : IHTMLElement;
        TagsList : IHTMLElementCollection;
        Index    : Integer;
      begin
        Result:='';
        TagsList := ABody.getElementsByTagName('input');
        for Index := 0 to TagsList.length-1 do
        begin
          Tag:=TagsList.item(Index, EmptyParam) As IHTMLElement;
          if CompareText(Tag.id,Id)=0 then
            Result := Tag.getAttribute('value', 0);
        end;
      end;

begin
  //is a valid command?
  if TOleEnum(Command) <> CSC_UPDATECOMMANDS then //-1
    Exit;

  //The page is loaded?
  ADocument := WebBrowser1.Document as IHTMLDocument2;
  if not Assigned(ADocument) then
    Exit;

  //the page has body?
  if not Supports(ADocument.body, IHTMLElement2, ABody) then
    exit;

  // get the values of the Latitude and Longitude
  Lat :=GetIdValue('LatValue');
  Lng :=GetIdValue('LngValue');

  //Now process the data
  if  (Lat<>'') and (Lng<>'') and ((Lat<>Latitude.Text) or (Lng<>Longitude.Text)) then
  begin
    Latitude.Text :=Lat;
    Longitude.Text:=Lng;

  end;
end;

Finally this is the full source code for the demo application

unit uMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OleCtrls, SHDocVw, StdCtrls, ExtCtrls, XPMan, ComCtrls,MSHTML;

type
  TFrmMain = class(TForm)
    WebBrowser1: TWebBrowser;
    PanelHeader: TPanel;
    ButtonGotoLocation: TButton;
    XPManifest1: TXPManifest;
    LabelLatitude: TLabel;
    LabelLongitude: TLabel;
    Longitude: TEdit;
    Latitude: TEdit;
    ButtonClearMarkers: TButton;
    ListView1: TListView;
    Panel1: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure ButtonClearMarkersClick(Sender: TObject);
    procedure WebBrowser1CommandStateChange(ASender: TObject; Command: Integer;  Enable: WordBool);
    procedure ButtonGotoLocationClick(Sender: TObject);
  private
    HTMLWindow2: IHTMLWindow2;
    procedure AddLatLngToList(const Lat,Lng:string);
  public
  end;

var
  FrmMain: TFrmMain;

implementation

{$R *.dfm}

uses
   ActiveX;

const
HTMLStr: AnsiString =
'<html> '+
'<head> '+
'<meta name="viewport" content="initial-scale=1.0, user-scalable=yes" /> '+
'<script type="text/javascript">// <![CDATA[
src</span>="http://maps.google.com/maps/api/js?sensor=false&language=en">
// ]]></script> '+
//'<script type="text/javascript">// <![CDATA[
src</span>="http://maps.google.com/maps/api/js?sensor=false">
// ]]></script> '+
'<script type="text/javascript"> '+
''+
''+
'  var geocoder; '+
'  var map;  '+
'  var markersArray = [];'+
''+
''+
'  function initialize() { '+
'    geocoder = new google.maps.Geocoder();'+
'    var latlng = new google.maps.LatLng(40.714776,-74.019213); '+
'    var myOptions = { '+
'      zoom: 13, '+
'      center: latlng, '+
'      mapTypeId: google.maps.MapTypeId.ROADMAP '+
'    }; '+
'    map = new google.maps.Map(document.getElementById("map_canvas"), myOptions); '+
'    map.set("streetViewControl", false);'+
'    google.maps.event.addListener(map, "click", '+
'         function(event) '+
'                        {'+
'                         document.getElementById("LatValue").value = event.latLng.lat(); '+
'                         document.getElementById("LngValue").value = event.latLng.lng(); '+
'                         PutMarker(document.getElementById("LatValue").value, document.getElementById("LngValue").value,"") '+
'                        } '+
'   ); '+
''+
'  } '+
''+
''+
'  function GotoLatLng(Lat, Lang) { '+
'   var latlng = new google.maps.LatLng(Lat,Lang);'+
'   map.setCenter(latlng);'+
'  }'+
''+
''+
'function ClearMarkers() {  '+
'  if (markersArray) {        '+
'    for (i in markersArray) {  '+
'      markersArray[i].setMap(null); '+
'    } '+
'  } '+
'}  '+
''+
'  function PutMarker(Lat, Lang, Msg) { '+
'   var latlng = new google.maps.LatLng(Lat,Lang);'+
'   var marker = new google.maps.Marker({'+
'      position: latlng, '+
'      map: map,'+
'      title: Msg+" ("+Lat+","+Lang+")"'+
'  });'+
'  markersArray.push(marker); '+
'  index= (markersArray.length % 10);'+
'  if (index==0) { index=10 } '+
'  icon = "http://www.google.com/mapfiles/kml/paddle/"+index+"-lv.png"; '+
'  marker.setIcon(icon); '+
'  }'+
''+
''+
''+'</script> '+
'</head> '+
''+
'<body onload="initialize()"> '+
'  <div id="map_canvas" style="width:100%; height:100%"></div> '+
'  <div id="latlong"> '+
'  <input type="hidden" id="LatValue" >'+
'  <input type="hidden" id="LngValue" >'+
'  </div>  '+
''+
'</body> '+
'</html> ';

procedure TFrmMain.FormCreate(Sender: TObject);
var
  aStream     : TMemoryStream;
begin
   WebBrowser1.Navigate('about:blank');
    if Assigned(WebBrowser1.Document) then
    begin
      aStream := TMemoryStream.Create;
      try
         aStream.WriteBuffer(Pointer(HTMLStr)^, Length(HTMLStr));
         //aStream.Write(HTMLStr[1], Length(HTMLStr));
         aStream.Seek(0, soFromBeginning);
         (WebBrowser1.Document as IPersistStreamInit).Load(TStreamAdapter.Create(aStream));
      finally
         aStream.Free;
      end;
      HTMLWindow2 := (WebBrowser1.Document as IHTMLDocument2).parentWindow;
    end;
end;

procedure TFrmMain.WebBrowser1CommandStateChange(ASender: TObject;  Command: Integer; Enable: WordBool);
var
  ADocument : IHTMLDocument2;
  ABody     : IHTMLElement2;
  Lat : string;
  Lng : string;

      function GetIdValue(const Id : string):string;
      var
        Tag      : IHTMLElement;
        TagsList : IHTMLElementCollection;
        Index    : Integer;
      begin
        Result:='';
        TagsList := ABody.getElementsByTagName('input');
        for Index := 0 to TagsList.length-1 do
        begin
          Tag:=TagsList.item(Index, EmptyParam) As IHTMLElement;
          if CompareText(Tag.id,Id)=0 then
            Result := Tag.getAttribute('value', 0);
        end;
      end;

begin
  if TOleEnum(Command) <> CSC_UPDATECOMMANDS then
    Exit;

  ADocument := WebBrowser1.Document as IHTMLDocument2;
  if not Assigned(ADocument) then
    Exit;

  if not Supports(ADocument.body, IHTMLElement2, ABody) then
    exit;

  Lat :=GetIdValue('LatValue');
  Lng :=GetIdValue('LngValue');
  if  (Lat<>'') and (Lng<>'') and ((Lat<>Latitude.Text) or (Lng<>Longitude.Text)) then
  begin
    Latitude.Text :=Lat;
    Longitude.Text:=Lng;
    AddLatLngToList(Lat, Lng);
  end;
end;

procedure TFrmMain.AddLatLngToList(const Lat, Lng: string);
var
  Item  : TListItem;
begin
   if (Lat<>'') and (Lng<>'') then
   begin
     Item:=ListView1.Items.Add;
     Item.Caption:=Lng;
     Item.SubItems.Add(Lat);
     Item.MakeVisible(False);
   end;
end;

procedure TFrmMain.ButtonClearMarkersClick(Sender: TObject);
begin
  HTMLWindow2.execScript('ClearMarkers()', 'JavaScript');
  ListView1.Items.Clear;
end;

procedure TFrmMain.ButtonGotoLocationClick(Sender: TObject);
begin
  if Assigned(ListView1.Selected) then
    HTMLWindow2.execScript(Format('GotoLatLng(%s,%s)',[ListView1.Selected.SubItems[0],ListView1.Selected.Caption]), 'JavaScript');
end;

end.

Check the source code on Github.


2 Comments

WMI Delphi Code Creator – New features and source code published in google code

Update : The WMI Delphi Code Creator now is hosted on Github.

In the last months I’ been working in a new version of the WMI Delphi Code Creator, porting the original code from Delphi 2007 to XE, adding new features like support for Delphi Prism and Free Pascal, and improving the source code generated by the tool. Now is time to show the results, so the new version is here with many new features,  also  the full source code is now available in the google code project hosting site under the Mozilla Public License 1.1

 

Check the list of features of the current version

  • Can generate object pascal code compatible with one of these compilers Delphi Win32, Delphi -Prism (Oxygene) , Free Pascal
  • The Delphi code generated is compatible with  Delphi 7, 2005, BDS/Turbo 2006 and RAD Studio 2007, 2009, 2010, XE.
  • The Free Pascal code generated is compatible with these versions 2.4.2, 2.4.4
  • The Delphi prism .Net  (Oxygene) generated code is compatible with all the versions up to 4.0.23.741 (in newer versions must work too)
  • Full access to metadata of any WMI Class registered in the system including qualifiers, mof definition, properties, methods, events
  • You can access directly from the application the MSDN web page related to the WMI Class which your are using.
  • Compile and run the generated code directly form the application using the selected compiler.
  • Open the the generated Delphi code in any of these  Delphi IDE’s 7, 2005, BDS/Turbo 2006 and RAD Studio 2007, 2009, 2010, XE
  • Open the the generated Free Pascal code directly in the Lazarus IDE.
  • Open the the generated Delphi Prism code directly in Visual Studio 2008, Visual Studio 2010 or MonoDevelop.
  • Runs on Windows XP, 2003, 2008, Vista and 7.
  • Themes support for Syntax highlighting (+50 themes included) compatible with the Delphi IDE Theme Editor.

For download the new version of the application and more details go to project page


Leave a comment

How get and parse a manifest of an external application using delphi

A manifest is basically a XML file that contains settings that informs Windows how to handle a program when it is started.  The manifest can be embedded inside the program file (as a resource) or it can be located in a separate external XML file. In this article I will show how you can read a embedded windows application manifest from a exe using delphi and parse the information contained using XPath.

The manifest are full of rich information which you can use to determine for example the Requested Execution Levels  or the version of the comctl32.dll used by an application.

To read the manifest from a exe file you must use the LoadLibraryEx function with the LOAD_LIBRARY_AS_DATAFILE flag (or since windows vista you can use the LOAD_LIBRARY_AS_IMAGE_RESOURCE value instead) and the TResourceStream class.

Check this sample code which returns the manifest from a exe file as a string;

function  GetManifest(const FileName:string) : AnsiString;
var
  hModule  : THandle;
  Resource : TResourceStream;
begin
  Result:='';
  //load the file to read
  hModule:=LoadLibraryEx(PChar(FileName),0,LOAD_LIBRARY_AS_DATAFILE);
  try
     if hModule=0 then RaiseLastOSError;
     //check if exist the manifest inside of the file
     if FindResource(hModule, MakeIntResource(1), RT_MANIFEST)<>0 then
     begin
       //load the resource
       Resource:=TResourceStream.CreateFromID(hModule,1,RT_MANIFEST);
       try
         SetString(Result, PAnsiChar(Resource.Memory),Resource.Size);
       finally
         Resource.Free;
       end;
     end;
  finally
      FreeLibrary(hModule);
  end;
end;

Ok that was the easy part, now before to parse the xml check a sample manifest file generated by Delphi XE

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
  <assemblyIdentity
    type="win32"
    name="CodeGear RAD Studio"
    version="15.0.3890.34076" 
    processorArchitecture="*"/>
  <dependency>
    <dependentAssembly>
      <assemblyIdentity
        type="win32"
        name="Microsoft.Windows.Common-Controls"
        version="6.0.0.0"
        publicKeyToken="6595b64144ccf1df"
        language="*"
        processorArchitecture="*"/>
    </dependentAssembly>
  </dependency>
  <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">
    <security>
      <requestedPrivileges>
        <requestedExecutionLevel
          level="asInvoker"
          uiAccess="false"/>
        </requestedPrivileges>
    </security>
  </trustInfo>
</assembly>

As you can see exist two XML namespaces (urn:schemas-microsoft-com:asm.v1 and urn:schemas-microsoft-com:asm.v3) inside of the xml file, before to read the xml string using XPath you must consider these two namespaces.

See this code which deal with the xml and the namespaces

//the namespaces used
const
 assembly_namespace_V1='urn:schemas-microsoft-com:asm.v1';
 assembly_namespace_V2='urn:schemas-microsoft-com:asm.v2';
 assembly_namespace_V3='urn:schemas-microsoft-com:asm.v3';
var
  XmlDoc : OleVariant;
  ns     : string;
  Node   : OleVariant;
begin
  if Trim(FManifest)='' then exit;
  //create a Xml Dom instance
  XmlDoc       := CreateOleObject('Msxml2.DOMDocument.6.0');
  XmlDoc.Async := False;
  try
    //load the Xml string
    XmlDoc.LoadXML(FManifest);
    XmlDoc.SetProperty('SelectionLanguage','XPath');

    if (XmlDoc.parseError.errorCode <> 0) then
     raise Exception.CreateFmt('Error in Xml Data %s',[XmlDoc.parseError]);

    //set the namespaces alias
    ns := Format('xmlns:a=%s xmlns:b=%s xmlns:c=%s',[QuotedStr(assembly_namespace_V1),QuotedStr(assembly_namespace_V2),QuotedStr(assembly_namespace_V3)]);
    XmlDoc.setProperty('SelectionNamespaces', ns);

    //get the version of the manifest
    Node:=XmlDoc.selectSingleNode('/a:assembly/@manifestVersion');
    if not VarIsNull(Node) and not VarIsClear(Node) then
    FManifestVersion:=Node.text;

    //parsing then Assembly Identity
    Node:=XmlDoc.selectSingleNode('/a:assembly/a:assemblyIdentity');
    if not VarIsNull(Node) and not VarIsClear(Node) then
    begin
      FMainAssemblyIdentity.&type   :=Node.getAttribute('type');
      FMainAssemblyIdentity.name    :=Node.getAttribute('name');
      FMainAssemblyIdentity.language:=VarNullToStr(Node.getAttribute('language'));
      FMainAssemblyIdentity.version :=Node.getAttribute('version');
      FMainAssemblyIdentity.processorArchitecture:=VarNullToStr(Node.getAttribute('processorArchitecture'));
      FMainAssemblyIdentity.publicKeyToken       :=VarNullToStr(Node.getAttribute('publicKeyToken'));
    end;

    Node:=XmlDoc.selectSingleNode('/a:assembly/a:dependency/a:dependentAssembly/a:assemblyIdentity');
    if not VarIsNull(Node) and not VarIsClear(Node) then
    begin
      FDependentAssembly.&type   :=Node.getAttribute('type');
      FDependentAssembly.name    :=Node.getAttribute('name');
      FDependentAssembly.language:=VarNullToStr(Node.getAttribute('language'));
      FDependentAssembly.version :=Node.getAttribute('version');
      FDependentAssembly.processorArchitecture:=VarNullToStr(Node.getAttribute('processorArchitecture'));
      FDependentAssembly.publicKeyToken       :=VarNullToStr(Node.getAttribute('publicKeyToken'));
    end;

    //Now the tricky part. The requestedExecutionLevel can be located in one of these namespaces
    //urn:schemas-microsoft-com:asm.v2 or urn:schemas-microsoft-com:asm.v3
    Node:=XmlDoc.selectSingleNode('/a:assembly/b:trustInfo/b:security/b:requestedPrivileges/b:requestedExecutionLevel');
    //if not found the requestedExecutionLevel then
    if VarIsNull(Node) or VarIsClear(Node) then
    //try with the next namespace
      Node:=XmlDoc.selectSingleNode('/a:assembly/c:trustInfo/c:security/c:requestedPrivileges/c:requestedExecutionLevel');
    //contains data?
    if not VarIsNull(Node) and not VarIsClear(Node) then
    begin
      FRequestedExecutionLevel.level   :=Node.getAttribute('level');
      FRequestedExecutionLevel.uiAccess:=VarNullToStr(Node.getAttribute('uiAccess'));
    end;

  finally
    XmlDoc:=Unassigned;
  end;
end;

Finally check this class to read the content of an Manifest embedded in exe file.

{$APPTYPE CONSOLE}

uses
  ActiveX,
  Classes,
  Windows,
  Variants,
  ComObj,
  StrUtils,
  SysUtils;

type
  TAssemblyIdentity=record
    &type : string;
    name	: string;
    language: string;
    processorArchitecture	: string;
    version	: string;
    publicKeyToken: string;
  end;

  TRequestedExecutionLevel=record
    level    : string;
    uiAccess : string;
  end;

  TManifiestReader=class
  private
    FFileName: string;
    FManifest: AnsiString;
    FMainAssemblyIdentity: TAssemblyIdentity;
    FHasManifest: Boolean;
    FDependentAssembly: TAssemblyIdentity;
    FManifestVersion: string;
    FRequestedExecutionLevel: TRequestedExecutionLevel;
    procedure GetManifest;
    procedure LoadManifestData;
    function  VarNullToStr(Value:OleVariant):string;
  public
    property FileName : string read FFileName;
    property Manifest : AnsiString read FManifest;
    property ManifestVersion : string read FManifestVersion;
    property MainAssemblyIdentity : TAssemblyIdentity read FMainAssemblyIdentity;
    property DependentAssembly : TAssemblyIdentity read FDependentAssembly;
    property HasManifest : Boolean read FHasManifest;
    property RequestedExecutionLevel : TRequestedExecutionLevel read FRequestedExecutionLevel;
    constructor Create(const AFileName:string);
  end;

{ TReadManifiest }

constructor TManifiestReader.Create(const AFileName: string);
begin
  FFileName:=AFileName;
  FHasManifest:=False;
  GetManifest;
  LoadManifestData;
end;

procedure TManifiestReader.GetManifest;
var
  hModule  : THandle;
  Resource : TResourceStream;
begin
  FManifest:='';
  hModule:=LoadLibraryEx(PChar(FileName),0,LOAD_LIBRARY_AS_DATAFILE);
  try
     if hModule=0 then RaiseLastOSError;
     if FindResource(hModule, MakeIntResource(1), RT_MANIFEST)<>0 then
     begin
       Resource:=TResourceStream.CreateFromID(hModule,1,RT_MANIFEST);
       try
         SetString(FManifest, PAnsiChar(Resource.Memory),Resource.Size);
         FHasManifest:=True;
       finally
         Resource.Free;
       end;
     end;
  finally
      FreeLibrary(hModule);
  end;
end;

procedure TManifiestReader.LoadManifestData;
const
 assembly_namespace_V1='urn:schemas-microsoft-com:asm.v1';
 assembly_namespace_V2='urn:schemas-microsoft-com:asm.v2';
 assembly_namespace_V3='urn:schemas-microsoft-com:asm.v3';
var
  XmlDoc : OleVariant;
  ns     : string;
  Node   : OleVariant;
begin
  if Trim(FManifest)='' then exit;
  XmlDoc       := CreateOleObject('Msxml2.DOMDocument.6.0');
  XmlDoc.Async := False;
  try
    XmlDoc.LoadXML(FManifest);
    XmlDoc.SetProperty('SelectionLanguage','XPath');

    if (XmlDoc.parseError.errorCode <> 0) then
     raise Exception.CreateFmt('Error in Xml Data %s',[XmlDoc.parseError]);

    //set the namespaces alias
    ns := Format('xmlns:a=%s xmlns:b=%s xmlns:c=%s',[QuotedStr(assembly_namespace_V1),QuotedStr(assembly_namespace_V2),QuotedStr(assembly_namespace_V3)]);
    XmlDoc.setProperty('SelectionNamespaces', ns);

    //get the version of the manifest
    Node:=XmlDoc.selectSingleNode('/a:assembly/@manifestVersion');
    if not VarIsNull(Node) and not VarIsClear(Node) then
    FManifestVersion:=Node.text;

    Node:=XmlDoc.selectSingleNode('/a:assembly/a:assemblyIdentity');
    if not VarIsNull(Node) and not VarIsClear(Node) then
    begin
      FMainAssemblyIdentity.&type   :=Node.getAttribute('type');
      FMainAssemblyIdentity.name    :=Node.getAttribute('name');
      FMainAssemblyIdentity.language:=VarNullToStr(Node.getAttribute('language'));
      FMainAssemblyIdentity.version :=Node.getAttribute('version');
      FMainAssemblyIdentity.processorArchitecture:=VarNullToStr(Node.getAttribute('processorArchitecture'));
      FMainAssemblyIdentity.publicKeyToken       :=VarNullToStr(Node.getAttribute('publicKeyToken'));
    end;

    Node:=XmlDoc.selectSingleNode('/a:assembly/a:dependency/a:dependentAssembly/a:assemblyIdentity');
    if not VarIsNull(Node) and not VarIsClear(Node) then
    begin
      FDependentAssembly.&type   :=Node.getAttribute('type');
      FDependentAssembly.name    :=Node.getAttribute('name');
      FDependentAssembly.language:=VarNullToStr(Node.getAttribute('language'));
      FDependentAssembly.version :=Node.getAttribute('version');
      FDependentAssembly.processorArchitecture:=VarNullToStr(Node.getAttribute('processorArchitecture'));
      FDependentAssembly.publicKeyToken       :=VarNullToStr(Node.getAttribute('publicKeyToken'));
    end;

    Node:=XmlDoc.selectSingleNode('/a:assembly/b:trustInfo/b:security/b:requestedPrivileges/b:requestedExecutionLevel');
    if VarIsNull(Node) or VarIsClear(Node) then
      Node:=XmlDoc.selectSingleNode('/a:assembly/c:trustInfo/c:security/c:requestedPrivileges/c:requestedExecutionLevel');
    if not VarIsNull(Node) and not VarIsClear(Node) then
    begin
      FRequestedExecutionLevel.level   :=Node.getAttribute('level');
      FRequestedExecutionLevel.uiAccess:=VarNullToStr(Node.getAttribute('uiAccess'));
    end;

  finally
    XmlDoc:=Unassigned;
  end;
end;

function TManifiestReader.VarNullToStr(Value: OleVariant): string;
begin
  if VarIsNull(Value) then
    Result:=''
  else
    Result:=VarToStr(Value);
end;

Var
  ManifestReader : TManifiestReader;
begin
 try
    CoInitialize(nil);
    try
      ManifestReader:=TManifiestReader.Create('MyApplication.exe');
      try
        //Writeln(ManifestReader.Manifest);

        Writeln('Manifest version '+ManifestReader.ManifestVersion);
        Writeln('Main Assembly Identity');
        Writeln('----------------------');
        Writeln('type     '+ManifestReader.MainAssemblyIdentity.&type);
        Writeln('name     '+ManifestReader.MainAssemblyIdentity.name);
        Writeln('language '+ManifestReader.MainAssemblyIdentity.language);
        Writeln('version  '+ManifestReader.MainAssemblyIdentity.version);
        Writeln('processorArchitecture '+ManifestReader.MainAssemblyIdentity.processorArchitecture);
        Writeln('publicKeyToken        '+ManifestReader.MainAssemblyIdentity.publicKeyToken);
        Writeln('');

        Writeln('Dependent Assembly Identity');
        Writeln('---------------------------');
        Writeln('type     '+ManifestReader.DependentAssembly.&type);
        Writeln('name     '+ManifestReader.DependentAssembly.name);
        Writeln('language '+ManifestReader.DependentAssembly.language);
        Writeln('version  '+ManifestReader.DependentAssembly.version);
        Writeln('processorArchitecture '+ManifestReader.DependentAssembly.processorArchitecture);
        Writeln('publicKeyToken        '+ManifestReader.DependentAssembly.publicKeyToken);
        Writeln('');

        Writeln('Requested Execution Level');
        Writeln('---------------------------');
        Writeln('level     '+ManifestReader.RequestedExecutionLevel.level);
        Writeln('uiAccess  '+ManifestReader.RequestedExecutionLevel.uiAccess);

      finally
        ManifestReader.Free;
      end;
    finally
      CoUninitialize;
    end;
 except
    on E:Exception do
        Writeln(E.Classname, ':', E.Message);
 end;
  Readln;
end.

Additional resources