The Road to Delphi – a Blog about programming

Delphi – Free Pascal – Oxygene


11 Comments

Detecting installed Delphi versions.

The key to detect the Delphi (or Rad-Studio) installed versions in a system is check the existence of these registry keys under the HKEY_CURRENT_USER root.

UPDATE
Tondrej makes a good comment about to check the existence of the instalation in the HKEY_LOCAL_MACHINE root, so the code has been modified.

for Borland Delphi until version 7

\Software\Borland\Delphi\DelphiVersion for example for Delphi 7 must be \Software\Borland\Delphi\7.0

for Borland Delphi 8 to Borland Development Studio 2006

\Software\Borland\BDS\BdsVersion for example for Borland Development Studio 2005 must be \Software\Borland\BDS\2.0

for Codegear RAD Studio 2009 and 2010

\Software\CodeGear\BDS\BdsVersion for example for RAD Studio 2009 must be \Software\CodeGear\BDS\6.0

and finally for Embarcadero RAD Studio (XE to XE5)

\Software\Embarcadero\BDS\BdsVersion for example for RAD Studio XE2 must be \Software\Embarcadero\BDS\9.0

Now you must check (and read) the existence of the “App” Value  which store the location of the Delphi (or Rad Studio) IDE.

Putting all together you can create an structure like this to access the information in the windows registry.

type
  TDelphiVersions =
  (
  Delphi4,
  Delphi5,
  Delphi6,
  Delphi7,
  Delphi8,
  Delphi2005,
  Delphi2006,
  Delphi2007,
  Delphi2009,
  Delphi2010,
  DelphiXE,
  DelphiXE2,
  DelphiXE3,
  DelphiXE4,
  DelphiXE5
  );

const
  DelphiVersionsNames: array[TDelphiVersions] of string = (
    'Delphi 4',
    'Delphi 5',
    'Delphi 6',
    'Delphi 7',
    'Delphi 8',
    'BDS 2005',
    'BDS 2006',
    'RAD Studio 2007',
    'RAD Studio 2009',
    'RAD Studio 2010',
    'RAD Studio XE',
    'RAD Studio XE2',
    'RAD Studio XE3',
    'RAD Studio XE4',
    'RAD Studio XE5'
    );

  DelphiRegPaths: array[TDelphiVersions] of string = (
    '\Software\Borland\Delphi\4.0',
    '\Software\Borland\Delphi\5.0',
    '\Software\Borland\Delphi\6.0',
    '\Software\Borland\Delphi\7.0',
    '\Software\Borland\BDS\2.0',
    '\Software\Borland\BDS\3.0',
    '\Software\Borland\BDS\4.0',
    '\Software\Borland\BDS\5.0',
    '\Software\CodeGear\BDS\6.0',
    '\Software\CodeGear\BDS\7.0',
    '\Software\Embarcadero\BDS\8.0',
    '\Software\Embarcadero\BDS\9.0',
    '\Software\Embarcadero\BDS\10.0',
    '\Software\Embarcadero\BDS\11.0',
    '\Software\Embarcadero\BDS\12.0'
);

and declaring a couple of helper functions to facilitate the work

function RegKeyExists(const RegPath: string;const RootKey :HKEY): Boolean;
var
  Reg: TRegistry;
begin
  try
    Reg         := TRegistry.Create;
    try
      Reg.RootKey := RootKey;
      Result := Reg.KeyExists(RegPath);
    finally
      Reg.Free;
    end;
  except
    Result := False;
  end;
end;

function RegReadStr(const RegPath, RegValue:string; var Str: string;const RootKey :HKEY): Boolean;
var
  Reg: TRegistry;
begin
  try
    Reg := TRegistry.Create;
    try
      Reg.RootKey := RootKey;
      Result := Reg.OpenKey(RegPath, True);
      if Result then  Str:=Reg.ReadString(RegValue);
    finally
      Reg.Free;
    end;
  except
    Result := False;
  end;
end;

procedure ExtractIconFileToImageList(ImageList: TImageList; const Filename: string);
var
  FileInfo: TShFileInfo;
begin
  if FileExists(Filename) then
  begin
    FillChar(FileInfo, SizeOf(FileInfo), 0);
    SHGetFileInfo(PChar(Filename), 0, FileInfo, SizeOf(FileInfo), SHGFI_ICON or SHGFI_SMALLICON);
    if FileInfo.hIcon <> 0 then
    begin
      ImageList_AddIcon(ImageList.Handle, FileInfo.hIcon);
      DestroyIcon(FileInfo.hIcon);
    end;
  end;
end;

finally we can fill a listview with the result adding a fancy Delphi icon

Var
 item       : TListItem;
 DelphiComp : TDelphiVersions;
 FileName   : string;
 ImageIndex : Integer;
 Found      : Boolean;
begin
    for DelphiComp := Low(TDelphiVersions) to High(TDelphiVersions) do
    begin
       Found:=RegKeyExists(DelphiRegPaths[DelphiComp],HKEY_CURRENT_USER);
       if Found then
        Found:=RegReadStr(DelphiRegPaths[DelphiComp],'App',FileName,HKEY_CURRENT_USER) and FileExists(FileName);

       if not Found then
       begin
         Found:=RegKeyExists(DelphiRegPaths[DelphiComp],HKEY_LOCAL_MACHINE);
         if Found then
           Found:=RegReadStr(DelphiRegPaths[DelphiComp],'App',FileName,HKEY_LOCAL_MACHINE) and FileExists(FileName);
       end;

        if Found then
        begin
           item:=ListViewIDEs.Items.Add;
           item.Caption:=DelphiVersionsNames[DelphiComp];
           item.SubItems.Add(FileName);
           ExtractIconFileToImageList(ImageList1,Filename);
           ImageIndex     :=ImageList1.Count-1;
           item.ImageIndex:=ImageIndex;
        end;
    end;
end;

And the final result will look like this

Download the demo project (Delphi 2007) from here.


10 Comments

WMI Delphi Code Creator – New Features

Update :  to get last version  check the new page of this project

Many new features was added to the application

The tool allows you compile and run the generated code directly without leaving the application

check the screen to select the installed Delphi compiler to use.

and the compiler result output

Added support for call WMI methods

Check the generated code for the Win32_Process wmi class and the Create method.

//------------------------------------------------------------------------------
//     This code was generated by the Wmi Delphi Code Creator http://theroadtodelphi.wordpress.com
//     Version: 1.0.0.11
//
//
//
//     LIABILITY DISCLAIMER
//     THIS GENERATED CODE IS DISTRIBUTED "AS IS". NO WARRANTY OF ANY KIND IS EXPRESSED OR IMPLIED.
//     YOU USE IT AT YOUR OWN RISK. THE AUTHOR NOT WILL BE LIABLE FOR DATA LOSS,
//     DAMAGES AND LOSS OF PROFITS OR ANY OTHER KIND OF LOSS WHILE USING OR MISUSING THIS CODE.
//
//
//------------------------------------------------------------------------------
program GetWMI_Info;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj,
  Variants;

function VarArrayToStr(const vArray: variant): string;

    function _VarToStr(const V: variant): string;
    var
    Vt: integer;
    begin
    Vt := VarType(V);
        case Vt of
          varSmallint,
          varInteger  : Result := IntToStr(integer(V));
          varSingle,
          varDouble,
          varCurrency : Result := FloatToStr(Double(V));
          varDate     : Result := VarToStr(V);
          varOleStr   : Result := WideString(V);
          varBoolean  : Result := VarToStr(V);
          varVariant  : Result := VarToStr(Variant(V));
          varByte     : Result := char(byte(V));
          varString   : Result := String(V);
          varArray    : Result := VarArrayToStr(Variant(V));
        end;
    end;

var
i : integer;
begin
    Result := '[';
     if (VarType(vArray) and VarArray)=0 then
       Result := _VarToStr(vArray)
    else
    for i := VarArrayLowBound(vArray, 1) to VarArrayHighBound(vArray, 1) do
     if i=VarArrayLowBound(vArray, 1)  then
      Result := Result+_VarToStr(vArray[i])
     else
      Result := Result+'|'+_VarToStr(vArray[i]);

    Result:=Result+']';
end;

function VarStrNull(const V:OleVariant):string; //avoid problems with null strings
begin
  Result:='';
  if not VarIsNull(V) then
  begin
    if VarIsArray(V) then
       Result:=VarArrayToStr(V)
    else
    Result:=VarToStr(V);
  end;
end;

function GetWMIObject(const objectName: String): IDispatch; //create the Wmi instance
var
  chEaten: Integer;
  BindCtx: IBindCtx;
  Moniker: IMoniker;
begin
  OleCheck(CreateBindCtx(0, bindCtx));
  OleCheck(MkParseDisplayName(BindCtx, StringToOleStr(objectName), chEaten, Moniker));
  OleCheck(Moniker.BindToObject(BindCtx, nil, IDispatch, Result));
end;

//The Create method creates a new process.
//The method returns an integer value
//that can be interpretted as follows:
//0 - Successful completion.
//2 - The user
//does not have access to the requested information.
//3 - The user does not have
//sufficient privilge.
//8 - Unknown failure.
//9 - The path specified does not
//exist.
//21 - The specified parameter is invalid.
//Other - For integer values
//other than those listed above, refer to Win32 error code documentation.

procedure  Invoke_Win32_Process_Create;
var
  objWMIService   : OLEVariant;
  objInvoker      : OLEVariant;
  objInParams     : OLEVariant;
  objOutParams    : OLEVariant;
begin
  objWMIService := GetWMIObject(Format('winmgmts:\\%s\%s',['.','root\CIMV2']));
  objInvoker    := objWMIService.Get('Win32_Process');
  objInParams   := objInvoker.Methods_.Item('Create').InParameters.SpawnInstance_();
  objInParams.CommandLine:='notepad.exe';
  objOutParams  := objWMIService.ExecMethod('Win32_Process', 'Create', objInParams);
  Writeln('ProcessId           '+VarStrNull(objOutParams.ProcessId));
  Writeln('ReturnValue         '+VarStrNull(objOutParams.ReturnValue));
end;

begin
 try
    CoInitialize(nil);
    try
      Invoke_Win32_Process_Create;
      Readln;
    finally
    CoUninitialize;
    end;
 except
    on E:Exception do
    begin
        Writeln(E.Classname, ':', E.Message);
        Readln;
    end;
  end;
end.

Added support for WMI events

Check the generated code for the __InstanceCreationEvent Event using as traget instance the Win32_Process class, this sample code check when new process is launched in the whole system.

//------------------------------------------------------------------------------
//     This code was generated by the Wmi Delphi Code Creator http://theroadtodelphi.wordpress.com
//     Version: 1.0.0.11
//
//
//
//     LIABILITY DISCLAIMER
//     THIS GENERATED CODE IS DISTRIBUTED "AS IS". NO WARRANTY OF ANY KIND IS EXPRESSED OR IMPLIED.
//     YOU USE IT AT YOUR OWN RISK. THE AUTHOR NOT WILL BE LIABLE FOR DATA LOSS,
//     DAMAGES AND LOSS OF PROFITS OR ANY OTHER KIND OF LOSS WHILE USING OR MISUSING THIS CODE.
//
//
//------------------------------------------------------------------------------
program GetWMI_Info;

{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils,
  ActiveX,
  ComObj,
  Variants;

function VarArrayToStr(const vArray: variant): string;

    function _VarToStr(const V: variant): string;
    var
    Vt: integer;
    begin
    Vt := VarType(V);
        case Vt of
          varSmallint,
          varInteger  : Result := IntToStr(integer(V));
          varSingle,
          varDouble,
          varCurrency : Result := FloatToStr(Double(V));
          varDate     : Result := VarToStr(V);
          varOleStr   : Result := WideString(V);
          varBoolean  : Result := VarToStr(V);
          varVariant  : Result := VarToStr(Variant(V));
          varByte     : Result := char(byte(V));
          varString   : Result := String(V);
          varArray    : Result := VarArrayToStr(Variant(V));
        end;
    end;

var
i : integer;
begin
    Result := '[';
     if (VarType(vArray) and VarArray)=0 then
       Result := _VarToStr(vArray)
    else
    for i := VarArrayLowBound(vArray, 1) to VarArrayHighBound(vArray, 1) do
     if i=VarArrayLowBound(vArray, 1)  then
      Result := Result+_VarToStr(vArray[i])
     else
      Result := Result+'|'+_VarToStr(vArray[i]);

    Result:=Result+']';
end;

function VarStrNull(const V:OleVariant):string; //avoid problems with null strings
begin
  Result:='';
  if not VarIsNull(V) then
  begin
    if VarIsArray(V) then
       Result:=VarArrayToStr(V)
    else
    Result:=VarToStr(V);
  end;
end;

function GetWMIObject(const objectName: String): IDispatch; //create the Wmi instance
var
  chEaten: Integer;
  BindCtx: IBindCtx;
  Moniker: IMoniker;
begin
  OleCheck(CreateBindCtx(0, bindCtx));
  OleCheck(MkParseDisplayName(BindCtx, StringToOleStr(objectName), chEaten, Moniker));
  OleCheck(Moniker.BindToObject(BindCtx, nil, IDispatch, Result));
end;

function KeyPressed:boolean; //Detect if an key is pressed
var
NumEvents   : DWORD;
ir          : _INPUT_RECORD;
bufcount    : DWORD;
StdIn       : THandle;
begin
    Result:=false;
    StdIn := GetStdHandle(STD_INPUT_HANDLE);
    NumEvents:=0;
    GetNumberOfConsoleInputEvents(StdIn,NumEvents);
    if NumEvents<> 0 then
    begin
        PeekConsoleInput(StdIn,ir,1,bufcount);
        if bufcount <> 0 then
        begin
            if ir.EventType = KEY_EVENT then
            begin
              if ir.Event.KeyEvent.bKeyDown then
                result:=true
              else
                FlushConsoleInputBuffer(StdIn);
            end
            else
            FlushConsoleInputBuffer(StdIn);
        end;
    end;
end;

Procedure  Event___InstanceCreationEvent_Target_Win32_Process;
var
  objWMIService   : OLEVariant;
  objEvent        : OLEVariant;
  objResult       : OLEVariant;
begin
  objWMIService := GetWMIObject('winmgmts:\\.\root\CIMV2');
  objEvent      := objWMIService.ExecNotificationQuery('Select * from __InstanceCreationEvent Within 1 Where TargetInstance ISA ''Win32_Process''    ');
  while not KeyPressed do
  begin
    try
     objResult := objEvent.NextEvent(100);
    except
     on E:EOleException do
     if EOleException(E).ErrorCode=HRESULT($80043001) then //Check for the timeout error wbemErrTimedOut 0x80043001
       objResult:=Null
     else
     raise;
    end;

    if not VarIsNull(objResult) then
    begin
      Writeln('Caption                  '+VarStrNull(objResult.TargetInstance.Caption));
      Writeln('CommandLine              '+VarStrNull(objResult.TargetInstance.CommandLine));
      Writeln('CreationClassName        '+VarStrNull(objResult.TargetInstance.CreationClassName));
      Writeln('CreationDate             '+VarStrNull(objResult.TargetInstance.CreationDate));
      Writeln('CSCreationClassName      '+VarStrNull(objResult.TargetInstance.CSCreationClassName));
      Writeln('CSName                   '+VarStrNull(objResult.TargetInstance.CSName));
      Writeln('Description              '+VarStrNull(objResult.TargetInstance.Description));
      Writeln('ExecutablePath           '+VarStrNull(objResult.TargetInstance.ExecutablePath));
      Writeln('ExecutionState           '+VarStrNull(objResult.TargetInstance.ExecutionState));
      Writeln('Handle                   '+VarStrNull(objResult.TargetInstance.Handle));
      Writeln('HandleCount              '+VarStrNull(objResult.TargetInstance.HandleCount));
      Writeln('InstallDate              '+VarStrNull(objResult.TargetInstance.InstallDate));
      Writeln('KernelModeTime           '+VarStrNull(objResult.TargetInstance.KernelModeTime));
      Writeln('MaximumWorkingSetSize    '+VarStrNull(objResult.TargetInstance.MaximumWorkingSetSize));
      Writeln('MinimumWorkingSetSize    '+VarStrNull(objResult.TargetInstance.MinimumWorkingSetSize));
      Writeln('Name                     '+VarStrNull(objResult.TargetInstance.Name));
      Writeln('OSCreationClassName      '+VarStrNull(objResult.TargetInstance.OSCreationClassName));
      Writeln('OSName                   '+VarStrNull(objResult.TargetInstance.OSName));
      Writeln('OtherOperationCount      '+VarStrNull(objResult.TargetInstance.OtherOperationCount));
      Writeln('OtherTransferCount       '+VarStrNull(objResult.TargetInstance.OtherTransferCount));
      Writeln('PageFaults               '+VarStrNull(objResult.TargetInstance.PageFaults));
      Writeln('PageFileUsage            '+VarStrNull(objResult.TargetInstance.PageFileUsage));
      Writeln('ParentProcessId          '+VarStrNull(objResult.TargetInstance.ParentProcessId));
      Writeln('PeakPageFileUsage        '+VarStrNull(objResult.TargetInstance.PeakPageFileUsage));
      Writeln('PeakVirtualSize          '+VarStrNull(objResult.TargetInstance.PeakVirtualSize));
      Writeln('PeakWorkingSetSize       '+VarStrNull(objResult.TargetInstance.PeakWorkingSetSize));
      Writeln('Priority                 '+VarStrNull(objResult.TargetInstance.Priority));
      Writeln('PrivatePageCount         '+VarStrNull(objResult.TargetInstance.PrivatePageCount));
      Writeln('ProcessId                '+VarStrNull(objResult.TargetInstance.ProcessId));
      Writeln('QuotaNonPagedPoolUsage   '+VarStrNull(objResult.TargetInstance.QuotaNonPagedPoolUsage));
      Writeln('QuotaPagedPoolUsage      '+VarStrNull(objResult.TargetInstance.QuotaPagedPoolUsage));
      Writeln('QuotaPeakNonPagedPoolUsage'+VarStrNull(objResult.TargetInstance.QuotaPeakNonPagedPoolUsage));
      Writeln('QuotaPeakPagedPoolUsage  '+VarStrNull(objResult.TargetInstance.QuotaPeakPagedPoolUsage));
      Writeln('ReadOperationCount       '+VarStrNull(objResult.TargetInstance.ReadOperationCount));
      Writeln('ReadTransferCount        '+VarStrNull(objResult.TargetInstance.ReadTransferCount));
      Writeln('SessionId                '+VarStrNull(objResult.TargetInstance.SessionId));
      Writeln('Status                   '+VarStrNull(objResult.TargetInstance.Status));
      Writeln('TerminationDate          '+VarStrNull(objResult.TargetInstance.TerminationDate));
      Writeln('ThreadCount              '+VarStrNull(objResult.TargetInstance.ThreadCount));
      Writeln('UserModeTime             '+VarStrNull(objResult.TargetInstance.UserModeTime));
      Writeln('VirtualSize              '+VarStrNull(objResult.TargetInstance.VirtualSize));
      Writeln('WindowsVersion           '+VarStrNull(objResult.TargetInstance.WindowsVersion));
      Writeln('WorkingSetSize           '+VarStrNull(objResult.TargetInstance.WorkingSetSize));
      Writeln('WriteOperationCount      '+VarStrNull(objResult.TargetInstance.WriteOperationCount));
      Writeln('WriteTransferCount       '+VarStrNull(objResult.TargetInstance.WriteTransferCount));
      Writeln('');
    end;
  end;
end;

begin
 try
    CoInitialize(nil);
    try
      Event___InstanceCreationEvent_Target_Win32_Process;
      Readln;
    finally
    CoUninitialize;
    end;
 except
    on E:Exception do
    begin
        Writeln(E.Classname, ':', E.Message);
        Readln;
    end;
  end;
end.

Improved WMi explorer window

this option now shows more info about the wmi classes, including the properties types, methods parameters (in, out)

also includes an option to view the values of the properties of the selected WMI class

and finally a new option called Search WMI Database, this option lets you search in all the wmi classes for a particular word.

see this sample image looking for the Motherboard word

Download The installer from here

And don’t forget , wich all your comments and suggestions are very welcome.


12 Comments

WMI Delphi Code Creator

UPDATE

The new page of this project is located here.

Introducing the WMI Delphi Code Creator © tool allows you to generate delphi code that uses WMI to complete a management task such as querying for wmi data.

This freeware tool is inspired by the  WMI Code Creator.

Features

  • Create full delphi console project
  • Create a 100% functional delphi procedure wich encapsulates the logic to retrieve WMI information
  • Full access to metadata of any WMI Class registered in the system
  • direct link to MSDN web page containig a description of the WMI Class

Todo

  • support fo call WMI methods.
  • support for WMI events
  • remote WMI support
  • Support more programming languages (delphi-prism, C++ builder)
  • Dynamic execution of generated code.
  • and more….

Used tools for write this application

Recommended Links about WMI

Screenshots

This slideshow requires JavaScript.

sample code generated by the application

//------------------------------------------------------------------------------
//     This code was generated by the Wmi Delphi Code Creator
//     Version: 1.0.0.1
//
//
//
//     LIABILITY DISCLAIMER
//     THIS GENERATED CODE IS DISTRIBUTED "AS IS". NO WARRANTY OF ANY KIND IS EXPRESSED OR IMPLIED.
//     YOU USE IT AT YOUR OWN RISK. THE AUTHOR NOT WILL BE LIABLE FOR DATA LOSS,
//     DAMAGES AND LOSS OF PROFITS OR ANY OTHER KIND OF LOSS WHILE USING OR MISUSING THIS CODE.
//
//
//------------------------------------------------------------------------------
program GetWMI_Info;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj,
  Variants;

function VarArrayToStr(const vArray: variant): string;

    function _VarToStr(const V: variant): string;
    var
    Vt: integer;
    begin
    Vt := VarType(V);
        case Vt of
          varSmallint,
          varInteger  : Result := IntToStr(integer(V));
          varSingle,
          varDouble,
          varCurrency : Result := FloatToStr(Double(V));
          varDate     : Result := VarToStr(V);
          varOleStr   : Result := WideString(V);
          varBoolean  : Result := VarToStr(V);
          varVariant  : Result := VarToStr(Variant(V));
          varByte     : Result := char(byte(V));
          varString   : Result := String(V);
          varArray    : Result := VarArrayToStr(Variant(V));
        end;
    end;

var
i : integer;
begin
    Result := '[';
     if (VarType(vArray) and VarArray)=0 then
       Result := _VarToStr(vArray)
    else
    for i := VarArrayLowBound(vArray, 1) to VarArrayHighBound(vArray, 1) do
     if i=VarArrayLowBound(vArray, 1)  then
      Result := Result+_VarToStr(vArray[i])
     else
      Result := Result+'|'+_VarToStr(vArray[i]);

    Result:=Result+']';
end;

function VarStrNull(const V:OleVariant):string; //avoid problems with null strings
begin
  Result:='Null';
  if not VarIsNull(V) then
  begin
    if VarIsArray(V) then
       Result:=VarArrayToStr(V)
    else
    Result:=VarToStr(V);
  end;
end;

function GetWMIObject(const objectName: String): IDispatch; //create the Wmi instance
var
  chEaten: Integer;
  BindCtx: IBindCtx;
  Moniker: IMoniker;
begin
  OleCheck(CreateBindCtx(0, bindCtx));
  OleCheck(MkParseDisplayName(BindCtx, StringToOleStr(objectName), chEaten, Moniker));
  OleCheck(Moniker.BindToObject(BindCtx, nil, IDispatch, Result));
end;

//
procedure  GetWin32_ShareInfo;
var
  objWMIService : OLEVariant;
  colItems      : OLEVariant;
  colItem       : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  objWMIService := GetWMIObject('winmgmts:\\localhost\root\CIMV2');
  colItems      := objWMIService.ExecQuery('SELECT * FROM Win32_Share','WQL',0);
  oEnum         := IUnknown(colItems._NewEnum) as IEnumVariant;
  while oEnum.Next(1, colItem, iValue) = 0 do
  begin
    Writeln(Format('AccessMask                     %s',[VarStrNull(colItem.AccessMask)]));
    Writeln(Format('AllowMaximum                   %s',[VarStrNull(colItem.AllowMaximum)]));
    Writeln(Format('Caption                        %s',[VarStrNull(colItem.Caption)]));
    Writeln(Format('Description                    %s',[VarStrNull(colItem.Description)]));
    Writeln(Format('InstallDate                    %s',[VarStrNull(colItem.InstallDate)]));
    Writeln(Format('MaximumAllowed                 %s',[VarStrNull(colItem.MaximumAllowed)]));
    Writeln(Format('Name                           %s',[VarStrNull(colItem.Name)]));
    Writeln(Format('Path                           %s',[VarStrNull(colItem.Path)]));
    Writeln(Format('Status                         %s',[VarStrNull(colItem.Status)]));
    Writeln(Format('Type                           %s',[VarStrNull(colItem.Type)]));
    Writeln('');
  end;
end;

begin
 try
    CoInitialize(nil);
    try
      GetWin32_ShareInfo;
      Readln;
    finally
    CoUninitialize;
    end;
 except
    on E:Exception do
    begin
        Writeln(E.Classname, ':', E.Message);
        Readln;
    end;
  end;
end.

Download from here.

Notice for Windows Vista, Windows 7 and Windows 2008  users, this application requires  run as administrator.

All your comments, suggestions and criticisms are very welcome.


4 Comments

Delphi : Enumerating Remote Desktop Servers in a network domain

using the WinApi WTSEnumerateServers function you can get a list of all Remote Desktop Servers in a network domain.

check the code. tested in Delphi 2007, Delphi 2010, Delphi XE – (Windows Xp, Windows 7, Windows 2008 Server)

program GetRemoteDesktops;

{$APPTYPE CONSOLE}

type
PWTS_SERVER_INFO = ^WTS_SERVER_INFO;
_WTS_SERVER_INFO = packed record
pServerName:LPTSTR;
end;
WTS_SERVER_INFO = _WTS_SERVER_INFO;
WTS_SERVER_INFO_Array  = Array [0..0] of WTS_SERVER_INFO;
PWTS_SERVER_INFO_Array =^WTS_SERVER_INFO_Array;

{$IFDEF UNICODE}
function WTSEnumerateServers( pDomainName: LPTSTR; Reserved: DWORD; Version: DWORD; ppServerInfo: PWTS_SERVER_INFO; pCount: PDWORD):BOOLEAN; stdcall; external 'wtsapi32.dll'  name 'WTSEnumerateServersW';
{$ELSE}
function WTSEnumerateServers( pDomainName: LPTSTR; Reserved: DWORD; Version: DWORD; ppServerInfo: PWTS_SERVER_INFO; pCount: PDWORD):BOOLEAN; stdcall; external 'wtsapi32.dll'  name 'WTSEnumerateServersA';
{$ENDIF}
procedure WTSFreeMemory(pMemory:Pointer);stdcall; external 'wtsapi32.dll' name 'WTSFreeMemory';

procedure GetRemoteDesktopsList(const Domain:PChar;const Servers:TStrings);
var
ppServerInfo : PWTS_SERVER_INFO_Array;//PWTS_SERVER_INFO;
pCount       : DWORD;
i            : integer;
begin
  Servers.Clear;
  ppServerInfo:=nil;
  try
    if WTSEnumerateServers(Domain,0,1,PWTS_SERVER_INFO(@ppServerInfo),@pCount) then
      for i := 0 to pCount - 1 do
        Servers.Add(ppServerInfo^[i].pServerName)
    else
    Raise Exception.Create(SysErrorMessage(GetLastError));
  finally
    if ppServerInfo<>nil then
    WTSFreeMemory(ppServerInfo);
  end;
end;


Leave a comment

DevExpress Webinars – What’s New in ExpressQuantumGrid 7

if you use the DevExpress VCL components, you can not miss this Webinar that will show the new features of ExpressQuantumGrid v7 component.
for register in this webinar go to this page.

The ExpressQuantumGrid is the longest-serving UI control in the DevExpress stable. It has been updated regularly over the years and now stands as the archetypal feature-rich grid on the Delphi platform. For version 7, there are new features like the layout view, several new charting types, and so on. Julian Bucknall will be showing these off, alongside the new features in ExpressBars 7.

for others DevExpress Webinars check this page.


3 Comments

Fun with Delphi Rtti – Dump a TRttiType Definition

Here ‘s a sample code of how you can dump the declaration of a TRttiType using the Rtti.

Supports classes, records and interfaces.

Delphi

//Author  Rodrigo Ruz V. 2010-10-10
uses
  Rtti,
  TypInfo,
  Classes,
  Generics.Collections,
  SysUtils;

function  DumpTypeDefinition(ATypeInfo: Pointer;OnlyDeclarated:Boolean=False) : string;

  //add and format a field
  procedure AddField(List:TStrings;lField : TRttiField);
  begin
     if Assigned(lField.FieldType) then
      List.Add((Format('   %-20s:%s;',[lField.Name,lField.FieldType.Name])))
     else
      List.Add((Format('   %-20s:%s;',[lField.Name,'Unknow'])));
  end;

  //add and format a method
  procedure AddMethod(List:TStrings;lMethod : TRttiMethod);
  begin
     List.Add((Format('   %s;',[lMethod.ToString])));
  end;

  //add and format a Property
  procedure AddProperty(List:TStrings;lProperty : TRttiProperty);
  begin
     List.Add((Format('   %s;',[lProperty.ToString])));
  end;

const
 sType          = 'type';
 sIndent        = '  ';
 ArrVisibility  : Array[TMemberVisibility] of string = ('private','protected','public','published');//Helper array for Visibility
var
  ctx       : TRttiContext;
  lType     : TRttiType;
  lMethod   : TRttiMethod;
  lProperty : TRttiProperty;
  lField    : TRttiField;
  Definition: TObjectDictionary<string, TStrings>;
  i         : TMemberVisibility;
begin
   Result:='No Rtti Information';
   ctx       := TRttiContext.Create;
   Definition:= TObjectDictionary<string, TStrings>.Create([doOwnsValues]);
   try

     if not Assigned(ATypeInfo) then exit;
     lType:=ctx.GetType(ATypeInfo);
     if not Assigned(lType) then exit;

     Definition.Add(sType,TStringList.Create);
     Definition.Items[sType].Add('type');

     //Initialize the buffers to hold the data
     for i:=Low(TMemberVisibility) to High(TMemberVisibility) do
     begin
      Definition.Add(ArrVisibility[i]  ,TStringList.Create);
      Definition.Items[ArrVisibility[i]].Add(sIndent+ArrVisibility[i]);
     end;

     case lType.TypeKind of
       tkUnknown    : ;
       tkInteger    : ;
       tkChar       : ;
       tkEnumeration: ;
       tkFloat      : ;
       tkString     : ;
       tkSet        : ;
       tkClass      :
                     begin
                       //get the main definition
                       if Assigned(lType.BaseType) then
                        Definition.Items[sType].Add(Format('%s%s=class(%s)',[sIndent,lType.Name,lType.BaseType.Name]))
                       else
                        Definition.Items[sType].Add(Format('%s%s=class',[sIndent,lType.Name]));
                     end;
       tkMethod     : ;
       tkWChar      : ;
       tkLString    : ;
       tkWString    : ;
       tkVariant    : ;
       tkArray      : ;
       tkRecord     : begin
                       //get the main definition
                        Definition.Items[sType].Add(Format('%s%s=record',[sIndent,lType.Name]));
                      end;

       tkInterface  :
                     begin
                       //get the main definition
                       if Assigned(lType.BaseType) then
                        Definition.Items[sType].Add(Format('%s%s=Interface(%s)',[sIndent,lType.Name,lType.BaseType.Name]))
                       else
                        Definition.Items[sType].Add(Format('%s%s=Interface',[sIndent,lType.Name]));

                     end;
       tkInt64      : ;
       tkDynArray   : ;
       tkUString    : ;
       tkClassRef   : ;
       tkPointer    : ;
       tkProcedure  : ;
     end;

       //add the fields
       if OnlyDeclarated then
         for lField in lType.GetDeclaredFields do
           AddField(Definition.Items[ArrVisibility[lField.Visibility]],lField)
       else
         for lField in lType.GetFields do
           AddField(Definition.Items[ArrVisibility[lField.Visibility]],lField);

       //add the methods
       if OnlyDeclarated then
         for lMethod in lType.GetDeclaredMethods do
           AddMethod(Definition.Items[ArrVisibility[lMethod.Visibility]],lMethod)
       else
         for lMethod in lType.GetMethods do
           AddMethod(Definition.Items[ArrVisibility[lMethod.Visibility]],lMethod);

       //add the Properties
       if OnlyDeclarated then
         for lProperty in lType.GetDeclaredProperties do
           AddProperty(Definition.Items[ArrVisibility[lProperty.Visibility]],lProperty)
       else
         for lProperty in lType.GetProperties do
           AddProperty(Definition.Items[ArrVisibility[lProperty.Visibility]],lProperty);

     for i:=Low(TMemberVisibility) to High(TMemberVisibility) do
      if Definition.Items[ArrVisibility[i]].Count>1 then
       Definition.Items[sType].AddStrings(Definition.Items[ArrVisibility[i]]);

     Definition.Items[sType].Add(sIndent+'end;');
     Result:=Definition.Items[sType].Text;
   finally
    Definition.free;
    ctx.free;
   end;
end;

Use in this way

//to dump a Class
DumpTypeDefinition(TypeInfo(TStringList));
//or
DumpTypeDefinition(TStringList.ClassInfo);

OutPut

the output is this

type
  TStringList=class(TStrings)
  private
   FList               : PStringItemList ;
   FCount              :Integer;
   FCapacity           :Integer;
   FSorted             :Boolean;
   FDuplicates         :TDuplicates;
   FCaseSensitive      :Boolean;
   FOnChange           :TNotifyEvent;
   FOnChanging         :TNotifyEvent;
   FOwnsObject         :Boolean;
   FEncoding           :TEncoding;
   FDefined            :TStringsDefined;
   FDefaultEncoding    :TEncoding;
   FDelimiter          :Char;
   FLineBreak          :string;
   FQuoteChar          :Char;
   FNameValueSeparator :Char;
   FStrictDelimiter    :Boolean;
   FUpdateCount        :Integer;
   FAdapter            :IStringsAdapter;
   FWriteBOM           :Boolean;
  public
   constructor Create;
   constructor Create(OwnsObjects: Boolean);
   class destructor Destroy;
   function Add(const S: string): Integer;
   function AddObject(const S: string; AObject: TObject): Integer;
   procedure Assign(Source: TPersistent);
   procedure Clear;
   procedure Delete(Index: Integer);
   procedure Exchange(Index1: Integer; Index2: Integer);
   function Find(const S: string; var Index: Integer): Boolean;
   function IndexOf(const S: string): Integer;
   procedure Insert(Index: Integer; const S: string);
   procedure InsertObject(Index: Integer; const S: string; AObject: TObject);
   procedure Sort;
   procedure CustomSort(Compare: TStringListSortCompare);
   constructor Create;
   class destructor Destroy;
   function Add(const S: string): Integer;
   function AddObject(const S: string; AObject: TObject): Integer;
   procedure Append(const S: string);
   procedure AddStrings(Strings: TStrings);
   procedure AddStrings(const Strings: TArray);
   procedure AddStrings(const Strings: TArray; const Objects: TAr
ray);
   procedure Assign(Source: TPersistent);
   procedure BeginUpdate;
   procedure Clear;
   procedure Delete(Index: Integer);
   procedure EndUpdate;
   function Equals(Strings: TStrings): Boolean;
   procedure Exchange(Index1: Integer; Index2: Integer);
   function GetEnumerator: TStringsEnumerator;
   function GetText: PWideChar;
   function IndexOf(const S: string): Integer;
   function IndexOfName(const Name: string): Integer;
   function IndexOfObject(AObject: TObject): Integer;
   procedure Insert(Index: Integer; const S: string);
   procedure InsertObject(Index: Integer; const S: string; AObject: TObject);
   procedure LoadFromFile(const FileName: string);
   procedure LoadFromFile(const FileName: string; Encoding: TEncoding);
   procedure LoadFromStream(Stream: TStream);
   procedure LoadFromStream(Stream: TStream; Encoding: TEncoding);
   procedure Move(CurIndex: Integer; NewIndex: Integer);
   procedure SaveToFile(const FileName: string);
   procedure SaveToFile(const FileName: string; Encoding: TEncoding);
   procedure SaveToStream(Stream: TStream);
   procedure SaveToStream(Stream: TStream; Encoding: TEncoding);
   procedure SetText(Text: PWideChar);
   function ToStringArray: TArray;
   function ToObjectArray: TArray;
   class destructor Destroy;
   procedure Assign(Source: TPersistent);
   function GetNamePath: string;
   constructor Create;
   procedure Free;
   class function InitInstance(Instance: Pointer): TObject;
   procedure CleanupInstance;
   function ClassType: TClass;
   class function ClassName: string;
   class function ClassNameIs(const Name: string): Boolean;
   class function ClassParent: TClass;
   class function ClassInfo: Pointer;
   class function InstanceSize: Integer;
   class function InheritsFrom(AClass: TClass): Boolean;
   class function MethodAddress(const Name: ShortString): Pointer;
   class function MethodAddress(const Name: string): Pointer;
   class function MethodName(Address: Pointer): string;
   function FieldAddress(const Name: ShortString): Pointer;
   function FieldAddress(const Name: string): Pointer;
   function GetInterface(const IID: TGUID; out Obj): Boolean;
   class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
   class function GetInterfaceTable: PInterfaceTable;
   class function UnitName: string;
   function Equals(Obj: TObject): Boolean;
   function GetHashCode: Integer;
   function ToString: string;
   function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HRESU
LT;
   procedure AfterConstruction;
   procedure BeforeDestruction;
   procedure Dispatch(var Message);
   procedure DefaultHandler(var Message);
   class function NewInstance: TObject;
   procedure FreeInstance;
   class destructor Destroy;
   property Duplicates: TDuplicates;
   property Sorted: Boolean;
   property CaseSensitive: Boolean;
   property OnChange: TNotifyEvent;
   property OnChanging: TNotifyEvent;
   property OwnsObjects: Boolean;
   property Capacity: Integer;
   property CommaText: string;
   property Count: Integer;
   property DefaultEncoding: TEncoding;
   property Delimiter: Char;
   property DelimitedText: string;
   property Encoding: TEncoding;
   property LineBreak: string;
   property QuoteChar: Char;
   property NameValueSeparator: Char;
   property StrictDelimiter: Boolean;
   property Text: string;
   property StringsAdapter: IStringsAdapter;
   property WriteBOM: Boolean;
  end;
//to dump a Class with only the declarateds fields, methods and properties
DumpTypeDefinition(TypeInfo(TStringList),True);
//or
DumpTypeDefinition(TStringList.ClassInfo,True);

the output

type
  TStringList=class(TStrings)
  private
   FList               : PStringItemList;
   FCount              :Integer;
   FCapacity           :Integer;
   FSorted             :Boolean;
   FDuplicates         :TDuplicates;
   FCaseSensitive      :Boolean;
   FOnChange           :TNotifyEvent;
   FOnChanging         :TNotifyEvent;
   FOwnsObject         :Boolean;
  public
   constructor Create;
   constructor Create(OwnsObjects: Boolean);
   class destructor Destroy;
   function Add(const S: string): Integer;
   function AddObject(const S: string; AObject: TObject): Integer;
   procedure Assign(Source: TPersistent);
   procedure Clear;
   procedure Delete(Index: Integer);
   procedure Exchange(Index1: Integer; Index2: Integer);
   function Find(const S: string; var Index: Integer): Boolean;
   function IndexOf(const S: string): Integer;
   procedure Insert(Index: Integer; const S: string);
   procedure InsertObject(Index: Integer; const S: string; AObject: TObject);
   procedure Sort;
   procedure CustomSort(Compare: TStringListSortCompare);
   property Duplicates: TDuplicates;
   property Sorted: Boolean;
   property CaseSensitive: Boolean;
   property OnChange: TNotifyEvent;
   property OnChanging: TNotifyEvent;
   property OwnsObjects: Boolean;
  end;
//to dump a record
DumpTypeDefinition(TypeInfo(TSysLocale));

the output look like this

type
  TSysLocale=record
  public
   DefaultLCID         :Integer;
   PriLangID           :Integer;
   SubLangID           :Integer;
   FarEast             :Boolean;
   MiddleEast          :Boolean;
  end;
//finally to dump an interface
DumpTypeDefinition(TypeInfo(IInterfaceList));


Leave a comment

Fun with Delphi Rtti – Building a Unit Dependency Tree

You can build a unit dependency tree, wich shows the direct dependency for each unit in your project using the New Rtti.

Here a short description of the algorithm used in this code.

  • For each Type(TRttiType) in the list do the following
  • check if the basetype exist in the same unit else add the unit to the list.
  • for each public field in the current type check if exist in the same unit else add the unit to the list.
  • for each method in the current type with an valid ReturnType check if exist in the same unit else add the unit to the list.
  • for each property in the current type check if exist in the same unit else add the unit to the list.

Limitations:

  • Only show direct dependency of the units (example if Unit A depends on Unit B and Unit B depends on UnitC, the tree will show wich the Unit A depends on only of Unit B)
  • Only supports Types with Rtti info.
  • Due to Rtti Limitations only supports public fields (TRttiField).
uses
Rtti,
Generics.Collections,
TypInfo;

procedure FillTreeUnits(TreeViewUnits:TTreeView);
var
  ctx      : TRttiContext;
  TypeList : TArray<TRttiType>;
  lType    : TRttiType;
  lMethod  : TRttiMethod;
  lProperty: TRttiProperty;
  lField   : TRttiField;
  Node     : TTreeNode;
  UnitName : string;
  RefUnit  : string;
  UnitsDict: TObjectDictionary<String, TStringList>;
  UnitList : TStringList;

      function GetUnitName(lType: TRttiType): string;
      begin
        {
        if lType.IsInstance then
        Result:=lType.UnitName
        else
        }
        Result := StringReplace(lType.QualifiedName, '.' + lType.Name, '',[rfReplaceAll]);
      end;

      //Check if exist the Unit in the Dictionary and if has a Unit Children in the associated list
      procedure CheckAndAdd(UnitName,RefUnit:string);
      begin
            if UnitName<>RefUnit then
             if not UnitsDict.ContainsKey(UnitName) then
             begin
               UnitList:=TStringList.Create;
               UnitList.Add(RefUnit);
               UnitsDict.Add(UnitName,UnitList);
             end
             else
             begin
               UnitList:=UnitsDict.Items[UnitName];
               if UnitList.IndexOf(RefUnit)<0 then
               UnitList.Add(RefUnit);
             end;
      end;

begin
  ctx       := TRttiContext.Create;
  UnitsDict := TObjectDictionary<String, TStringList>.Create([doOwnsValues]);
  TreeViewUnits.Items.BeginUpdate;
  try
    TreeViewUnits.Items.Clear;
    TypeList:= ctx.GetTypes;

      //Fill a Dictionary with all the units and the dependencies
      for lType in TypeList do
      begin
             //Search references to another units in the BaseType
             UnitName:=GetUnitName(lType);
             if Assigned(lType.BaseType) then
                CheckAndAdd(UnitName,GetUnitName(lType.BaseType));

             //Search references to another units in the public fields (due to RTTI limitations only works with public fields)
             for lField in lType.GetDeclaredFields do
             if Assigned(lField.FieldType) and (lField.FieldType.IsPublicType) then
                CheckAndAdd(UnitName,GetUnitName(lField.FieldType));

             //Search references to another units in the properties
             for lProperty in lType.GetDeclaredProperties do
             if Assigned(lProperty.PropertyType) then
                CheckAndAdd(UnitName,GetUnitName(lProperty.PropertyType));

             //Search references to another units in functions with ExtendedInfo (HasExtendedInfo=True)
             for lMethod in lType.GetDeclaredMethods do
             if (lMethod.HasExtendedInfo) and (lMethod.MethodKind in [mkFunction,mkClassFunction]) then
                CheckAndAdd(UnitName,GetUnitName(lMethod.ReturnType));
        end;

       //finally fill the treeview
       for UnitName in UnitsDict.Keys do
       begin
          UnitList:=UnitsDict.Items[UnitName];
          Node    :=TreeViewUnits.Items.Add(nil,UnitName);
           for RefUnit in UnitList do
             TreeViewUnits.Items.AddChild(Node,RefUnit);
       end;

  finally
    UnitsDict.Destroy;
    ctx.Free;
    TreeViewUnits.Items.EndUpdate;
  end;
end;

Finally the output for the source code

Follow

Get every new post delivered to your Inbox.

Join 708 other followers