The Road to Delphi

Delphi – Free Pascal – Oxygene


4 Comments

Be careful when you import the Microsoft WMIScripting Library

Commonly when we need use the WMI, we import the Microsoft WMIScripting Library from delphi using the Import Component Wizard, but depending on the version of windows that we use the results can be different, although the version showed by the wizard is the same.

Check this sample.

if you uses Windows 7 and Delphi 2007 to import the Microsoft WMIScripting Library as is shown in this picture.

Delphi will generate a unit called WbemScripting_TLB wich is based in the C:\Windows\system32\wbem\wbemdisp.TLB file.

Now if you look the ISWbemObjectSet interface the declaration will look like this

// *********************************************************************//
// Interface: ISWbemObjectSet
// Flags:     (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID:      {76A6415F-CB41-11D1-8B02-00600806D9B6}
// *********************************************************************//
  ISWbemObjectSet = interface(IDispatch)
    ['{76A6415F-CB41-11D1-8B02-00600806D9B6}']
    function Get__NewEnum: IUnknown; safecall;
    function Item(const strObjectPath: WideString; iFlags: Integer): ISWbemObject; safecall;
    function Get_Count: Integer; safecall;
    function Get_Security_: ISWbemSecurity; safecall;
    function ItemIndex(lIndex: Integer): ISWbemObject; safecall;
    property _NewEnum: IUnknown read Get__NewEnum;
    property Count: Integer read Get_Count;
    property Security_: ISWbemSecurity read Get_Security_;
  end;

Doing the same operation from Windows XP the declaration for the ISWbemObjectSet interface is this

// *********************************************************************//
// Interface: ISWbemObjectSet
// Flags:     (4560) Hidden Dual NonExtensible OleAutomation Dispatchable
// GUID:      {76A6415F-CB41-11D1-8B02-00600806D9B6}
// *********************************************************************//
  ISWbemObjectSet = interface(IDispatch)
    ['{76A6415F-CB41-11D1-8B02-00600806D9B6}']
    function Get__NewEnum: IUnknown; safecall;
    function Item(const strObjectPath: WideString; iFlags: Integer): ISWbemObject; safecall;
    function Get_Count: Integer; safecall;
    function Get_Security_: ISWbemSecurity; safecall;
    property _NewEnum: IUnknown read Get__NewEnum;
    property Count: Integer read Get_Count;
    property Security_: ISWbemSecurity read Get_Security_;
  end;

As you can see the difference is the ItemIndex function, which according to Microsoft is available since Windows Vista.

function ItemIndex(lIndex: Integer): ISWbemObject; safecall;

this function returns a SWbemObject associated with the specified index into the collection returned by the SWbemObjectSet

The problem is which you have a simple code like this (compiled under Windows Vista, 2008 or 7)

uses
  ActiveX,
  Variants,
  SysUtils,
  WbemScripting_TLB in '..\..\..\Documents\RAD Studio\5.0\Imports\WbemScripting_TLB.pas';

procedure ShowMotherBoardInfo;
var
  WMIServices    : ISWbemServices;
  SWbemObjectSet : ISWbemObjectSet;
  SObject        : Variant;
  I              : Integer;
begin
  WMIServices := CoSWbemLocator.Create.ConnectServer('.', 'root\cimv2','', '', '', '', 0, nil);
  SWbemObjectSet := WMIServices.ExecQuery('Select * FROM Win32_BaseBoard', 'WQL', 0, nil);
  for I := 0 to SWbemObjectSet.Count - 1 do
  begin
    SObject := SWbemObjectSet.ItemIndex(I);
    Writeln('SerialNumber '+SObject.SerialNumber);
  end;
end;

and you deploy your exe in a Windows XP system, your application will raise an awful exception like this

EAccessViolation:Access violation at address 00570053. Write of address 5A732CB4

because that function does not exist in the WMI deployed with Windows XP.

 

if  look deeper in the wbemdisp.TLB file you can see the differences in the versions

Windows XP version information for the wbemdisp.TLB file

Length Of Struc: 039Ch
Length Of Value: 0034h
Type Of Struc:   0000h
Info:            VS_VERSION_INFO
Signature:       FEEF04BDh
Struc Version:   1.0
File Version:    5.1.2600.0
Product Version: 5.1.2600.0
File Flags Mask: 0.63
File Flags:
File OS:         NT (WINDOWS32)
File Type:       DLL
File SubType:    UNKNOWN
File Date:       00:00:00  00/00/0000

     Struc has Child(ren). Size: 832 bytes.

Child Type:         StringFileInfo
Language/Code Page: 1033/1200
CompanyName:        Microsoft Corporation
FileDescription:    Typelib for WMI Scripting Interface
FileVersion:        5.1.2600.0 (xpclient.010817-1148)
InternalName:       wbemdisp
LegalCopyright:     © Microsoft Corporation. All rights reserved.
OriginalFilename:   wbemdisp.tlb
ProductName:        Microsoft® Windows® Operating System
ProductVersion:     5.1.2600.0

Child Type:         VarFileInfo
Translation:        1033/1200

Windows 7 version information for the wbemdisp.TLB file

Length Of Struc: 03ACh
Length Of Value: 0034h
Type Of Struc:   0000h
Info:            VS_VERSION_INFO
Signature:       FEEF04BDh
Struc Version:   1.0
File Version:    6.1.7600.16385
Product Version: 6.1.7600.16385
File Flags Mask: 0.63
File Flags:
File OS:         NT (WINDOWS32)
File Type:       DLL
File SubType:    UNKNOWN
File Date:       00:00:00  00/00/0000

     Struc has Child(ren). Size: 848 bytes.

Child Type:         StringFileInfo
Language/Code Page: 1033/1200
CompanyName:        Microsoft Corporation
FileDescription:    Typelib for WMI Scripting Interface
FileVersion:        6.1.7600.16385 (win7_rtm.090713-1255)
InternalName:       wbemdisp
LegalCopyright:     © Microsoft Corporation. All rights reserved.
OriginalFilename:   wbemdisp.tlb
ProductName:        Microsoft® Windows® Operating System
ProductVersion:     6.1.7600.16385

Child Type:         VarFileInfo
Translation:        1033/1200

and now the dump of the wbemdisp.TLB file

Windows XP Version

//A collection of Classes or Instances
Dispatch ISWbemObjectSet;
GUID = {76A6415F-CB41-11D1-8B02-00600806D9B6};
  function QueryInterface(riid: ^GUID; out ppvObj: ^^VOID); stdcall;
  function AddRef: UI4; stdcall;
  function Release: UI4; stdcall;
  function GetTypeInfoCount(out pctinfo: ^UINT); stdcall;
  function GetTypeInfo(itinfo: UINT; lcid: UI4; out pptinfo: ^^VOID); stdcall;
  function GetIDsOfNames(riid: ^GUID; rgszNames: ^^I1; cNames: UINT; lcid: UI4; out rgdispid: ^I4); stdcall;
  function Invoke(dispidMember: I4; riid: ^GUID; lcid: UI4; wFlags: UI2; pdispparams: ^DISPPARAMS; out pvarResult: ^Variant; out pexcepinfo: ^EXCEPINFO; out puArgErr: ^UINT); stdcall;
  property-get _NewEnum: IUnknown; stdcall;
  //Get an Object with a specific path from this collection
  function Item(strObjectPath: BSTR; out iFlags: I4): ^ISWbemObject; stdcall;
  //The number of items in this collection
  property-get Count: I4; stdcall;
  //The Security Configurator for this Object
  property-get Security_: ^ISWbemSecurity; stdcall;

Windows 7 Version

//A collection of Classes or Instances
Dispatch ISWbemObjectSet;
GUID = {76A6415F-CB41-11D1-8B02-00600806D9B6};
  function QueryInterface(riid: ^GUID; out ppvObj: ^^VOID); stdcall;
  function AddRef: UI4; stdcall;
  function Release: UI4; stdcall;
  function GetTypeInfoCount(out pctinfo: ^UINT); stdcall;
  function GetTypeInfo(itinfo: UINT; lcid: UI4; out pptinfo: ^^VOID); stdcall;
  function GetIDsOfNames(riid: ^GUID; rgszNames: ^^I1; cNames: UINT; lcid: UI4; out rgdispid: ^I4); stdcall;
  function Invoke(dispidMember: I4; riid: ^GUID; lcid: UI4; wFlags: UI2; pdispparams: ^DISPPARAMS; out pvarResult: ^Variant; out pexcepinfo: ^EXCEPINFO; out puArgErr: ^UINT); stdcall;
  property-get _NewEnum: IUnknown; stdcall;
  //Get an Object with a specific path from this collection
  function Item(strObjectPath: BSTR; out iFlags: I4): ^ISWbemObject; stdcall;
  //The number of items in this collection
  property-get Count: I4; stdcall;
  //The Security Configurator for this Object
  property-get Security_: ^ISWbemSecurity; stdcall;
  //Get an Object with a specific index from this collection
  function ItemIndex(lIndex: I4): ^ISWbemObject; stdcall;

returning to the original sample code , you can rewrite the procedure like this to avoid the problem

uses
  ActiveX,
  Variants,
  SysUtils,
  WbemScripting_TLB in '..\..\..\Documents\RAD Studio\5.0\Imports\WbemScripting_TLB.pas';

procedure ShowMotherBoardSerialNumber;
var
  WMIServices     : ISWbemServices;
  SWbemObjectSet  : ISWbemObjectSet;
  SObject         : ISWbemObject;
  Enum            : IEnumVariant;
  TempObj         : OleVariant;
  Value           : Cardinal;
  SWbemPropertySet: ISWbemPropertySet;
begin
  WMIServices := CoSWbemLocator.Create.ConnectServer('.', 'root\cimv2','', '', '', '', 0, nil);
  SWbemObjectSet := WMIServices.ExecQuery('Select * FROM Win32_BaseBoard', 'WQL', 0, nil);
  Enum := (SWbemObjectSet._NewEnum) as IEnumVariant;
  while (Enum.Next(1, TempObj, Value) = S_OK) do
  begin
    SObject     := IUnknown(tempObj) as ISWBemObject;
    SWbemPropertySet := SObject.Properties_;
    Writeln('SerialNumber '+SWbemPropertySet.Item('SerialNumber', 0).Get_Value);
  end;
end;

So the lesson is be careful when you import the Microsoft WMIScripting Library and check your code in another Windows versions, before your deploy the final version of your application.


4 Comments

Creating a TinyUrl from Delphi

The TinyUrl free service convert a long URL to small url, which is useful for example to make twitter posts.

to use this service from delphi you must make a request to this link http://tinyurl.com/api-create.php?url=the_url_to_convert_goes_here and the response is the TinyUrl generated

check the sample code to get the response

program DelphiTinyUrl;

{$APPTYPE CONSOLE}

uses
  WinInet,
  SysUtils;

function GetTinyUrl(Url:string):string;
const
tinyurl  = 'http://tinyurl.com/api-create.php?url=%s';
BuffSize = 2048;
var
  hInter   : HINTERNET;
  UrlHandle: HINTERNET;
  BytesRead: Cardinal;
  Buffer   : Pointer;
begin
  Result:='';
  hInter := InternetOpen('', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if Assigned(hInter) then
  begin
    GetMem(Buffer,BuffSize);
    try
        UrlHandle := InternetOpenUrl(hInter, PChar(Format(tinyurl,[Url])), nil, 0, INTERNET_FLAG_RELOAD, 0);
        if Assigned(UrlHandle) then
        begin
          InternetReadFile(UrlHandle, Buffer, BuffSize, BytesRead);
          if BytesRead>0 then
           SetString(Result, PAnsiChar(Buffer), BytesRead);
           InternetCloseHandle(UrlHandle);
        end;
    finally
      FreeMem(Buffer);
    end;
    InternetCloseHandle(hInter);
  end
end;

begin
  try
     Writeln(GetTinyUrl('https://theroadtodelphi.wordpress.com/'));
     Readln;
  except
    on E:Exception do
      Writeln(E.Classname, ': ', E.Message);
  end;
end.

and the response is

http://tinyurl.com/2ca52me


9 Comments

Create a SFX File with Delphi (Self Extracting Archives)

Have you noticed how some compressors like winrar ® or winzip ® can create self-extracting files. Today we will see how we can generate these files using the ZLib unit wich is included with delphi.

The logic goes like this

1) Create a exe which the capacity of decompress a resource, this project is responsible for extract the compressed data, which was previously stored as a resource inside of self.

This is the code to extract the data stored inside of the resource

procedure Extract;
var
  DeCompressStream : TDeCompressionStream;
  ResourceStream   : TResourceStream;
  DestFileStream   : TFileStream;
  FileNameDest     : String;
  RecSFX           : TRecSFX;
begin

  if FindResource(0, 'SFXDATA', RT_RCDATA)=0 then //find the compressed data
  begin
    Application.MessageBox('Sorry i am empty','Warning',MB_OK+MB_ICONWARNING);
    Exit;
  end
  else
  if FindResource(0, 'SFXREC', RT_RCDATA)=0 then //find the header data
  begin
    Application.MessageBox('Sorry i dont have header data','Warning',MB_OK+MB_ICONWARNING);
    Exit;
  end;

 try
    ResourceStream:= TResourceStream.Create(0,'SFXREC',RT_RCDATA); //read the header stored in the resorce named SFXREC
    try
        ResourceStream.Position:=0;
        Move(ResourceStream.Memory^,RecSFX,SizeOf(RecSFX));
        ProgressBarSfx.Max:=RecSFX.Size;
    finally
      ResourceStream.Free;
    end;

    ResourceStream:= TResourceStream.Create(0,'SFXDATA',RT_RCDATA); //read the compressed data stores in the SFXDATA resource
    try
      ProgressBarSfx.Max:=ResourceStream.Size;
      FileNameDest   := EditPath.Text+ChangeFileExt(ExtractFileName(ParamStr(0)),'');
      DestFileStream := TFileStream.Create(FileNameDest,fmCreate); //create the file to uncompress the data
      try
        DeCompressStream:=TDeCompressionStream.Create(ResourceStream);
        DeCompressStream.OnProgress:=DoProgress; //assign the OnProgress event to see the progress
        try
           DestFileStream.CopyFrom(DeCompressStream,RecSFX.Size); //decompress the data
        finally
          DeCompressStream.Free;
        end;
      finally
        DestFileStream.Free;
      end;
    finally
      ResourceStream.Free;
    end;
 except on e : exception do
   Application.MessageBox(PAnsiChar(e.Message),'Error',MB_OK+MB_ICONERROR);
 end;
end;

2) Transform this project in a resource and attach this resource to the second project, using the BRCC32.exe tool

create a file called Stub.rc with this content

STUB RT_RCDATA "SfxExtractor.exe"

now compile the rc file

BRCC32.exe Stub.rc

3) include the generated Stub.res file in the second project

{$R Stub.res}

4) Now the second project select a file to compress

5) Extract the STUB resource and then create a new exe file

var
  StubStream: TResourceStream;
begin
  StubStream := TResourceStream.Create( HInstance, 'STUB', 'RT_RCDATA');
  try
     DeleteFile(FSfxFileName);
     StubStream.SaveToFile(FSfxFileName);
  finally
    StubStream.Free;
  end;
  Result:=FileExists(FSfxFileName);
end;

6) Compress the selected file using the TCompressionStream class and add two resources to the New STUB exe,
one resource store the header info (Original filename, size) and the another store the compressed data.

check the code wich compress the data in a resource and create the two resources in the STUB exe.

procedure CreateSFX;
var
  SrcFileStream   : TFileStream;
  CompressedStream: TMemoryStream;
  hDestRes        : THANDLE;
  Compressor      : TCompressionStream;
  RecSFX          : TRecSFX;
begin
  SrcFileStream      := TFileStream.Create(FSrcFileName,fmOpenRead or fmShareDenyNone); //open the file to compress
  ProgressBarSfx.Max := SrcFileStream.Size;
 try
  try
    CompressedStream:= TMemoryStream.Create;
    try
      Compressor:=TCompressionStream.Create(GetCompressionLevel,CompressedStream); //create the stream to compress the data
      try
        Compressor.OnProgress:=DoProgress;
        Compressor.CopyFrom(SrcFileStream,0);
      finally
        Compressor.Free;
      end;
        //Write the header
        FillChar(RecSFX,SizeOf(RecSFX),#0);
        RecSFX.Size:=SrcFileStream.Size;
        Move(ExtractFileName(FSrcFileName)[1],RecSFX.Name,Length(ExtractFileName(FSrcFileName)));

        hDestRes:= BeginUpdateResource(PAnsiChar(FSfxFileName), False);
        if hDestRes <> 0 then
          if UpdateResource(hDestRes, RT_RCDATA,'SFXREC',0,@RecSFX,SizeOf(RecSFX)) then //create the resource in the exe with the header info
             if EndUpdateResource(hDestRes,FALSE) then
             else
             RaiseLastOSError
          else
          RaiseLastOSError
        else
        RaiseLastOSError;

        hDestRes:= BeginUpdateResource(PAnsiChar(FSfxFileName), False);
        if hDestRes <> 0 then
          if UpdateResource(hDestRes, RT_RCDATA,'SFXDATA',0,CompressedStream.Memory,CompressedStream.Size) then //create the resource in the exe with the compressed data
            if EndUpdateResource(hDestRes,FALSE) then //if all is ok show the summary info
            begin
               LabelInfo.Caption:=
               Format('SFX Created %sOriginal Size %s %sCompressed Size %s Ratio %n %%',[#13,FormatFloat('#,',SrcFileStream.Size),#13,FormatFloat('#,',CompressedStream.Size),CompressedStream.Size*100/SrcFileStream.Size]);
               ProgressBarSfx.Position:=ProgressBarSfx.Max;
               ButtonCreateSFX.Enabled:=False;
            end
            else
            RaiseLastOSError
          else
          RaiseLastOSError
        else
        RaiseLastOSError;
    finally
      CompressedStream.Free;
    end;
  finally
    SrcFileStream.Free;
  end;
 except on e : exception do
   Application.MessageBox(PAnsiChar(e.Message),'Error',MB_OK+MB_ICONERROR);
 end;
end;

You can add many features like password, checksum validation, encryption and others to the STUB Application. just keep in mind final file size of the STUB.

Finally when you run the second application (Project CreateSFX) and select a file the aplication will create a SFX file.

Project SfxExtractor

{$SetPEFlags 1}  //  remove relocation table

unit MainSFX;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls;

type
  TFrmMain = class(TForm)
    ButtonSelDir: TButton;
    EditPath: TEdit;
    ButtonExtract: TButton;
    ProgressBarSfx: TProgressBar;
    Label1: TLabel;
    procedure ButtonSelDirClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure ButtonExtractClick(Sender: TObject);
  private
    procedure Extract;
    procedure DoProgress(Sender: TObject);
  public
  end;

var
  FrmMain: TFrmMain;

implementation
{$R *.dfm}

uses
ShlObj,
ZLib,
Common;

function SelectFolderCallbackProc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData: LPARAM): Integer; stdcall;
begin
  if (uMsg = BFFM_INITIALIZED) then
    SendMessage(hwnd, BFFM_SETSELECTION, 1, lpData);
  Result := 0;
end;

function SelectFolder(hwndOwner: HWND;const Caption: string; var InitFolder: string): Boolean;
var
  ItemIDList: PItemIDList;
  idlRoot   : PItemIDList;
  Path      : PAnsiChar;
  BrowseInfo: TBrowseInfo;
begin
  Result := False;
  Path := StrAlloc(MAX_PATH);
  SHGetSpecialFolderLocation(hwndOwner, CSIDL_DRIVES, idlRoot);
  with BrowseInfo do
  begin
    hwndOwner := GetActiveWindow;
    pidlRoot  := idlRoot;
    SHGetSpecialFolderLocation(hwndOwner, CSIDL_DRIVES, idlRoot);
    pszDisplayName := StrAlloc(MAX_PATH);
    lpszTitle := PAnsiChar(Caption);
    lpfn      := @SelectFolderCallbackProc;
    lParam    := LongInt(PAnsiChar(InitFolder));
    ulFlags   := BIF_RETURNONLYFSDIRS OR BIF_USENEWUI;
  end;

  ItemIDList := SHBrowseForFolder(BrowseInfo);
  if (ItemIDList <> nil) then
    if SHGetPathFromIDList(ItemIDList, Path) then
    begin
      InitFolder := Path;
      Result    := True;
    end;
end;

procedure TFrmMain.Extract;
var
  DeCompressStream : TDeCompressionStream;
  ResourceStream   : TResourceStream;
  DestFileStream   : TFileStream;
  FileNameDest     : String;
  RecSFX           : TRecSFX;
begin

  if FindResource(0, 'SFXDATA', RT_RCDATA)=0 then
  begin
    Application.MessageBox('Sorry i am empty','Warning',MB_OK+MB_ICONWARNING);
    Exit;
  end
  else
  if FindResource(0, 'SFXREC', RT_RCDATA)=0 then
  begin
    Application.MessageBox('Sorry i dont have header data','Warning',MB_OK+MB_ICONWARNING);
    Exit;
  end;

 try
    ResourceStream:= TResourceStream.Create(0,'SFXREC',RT_RCDATA);
    try
        ResourceStream.Position:=0;
        Move(ResourceStream.Memory^,RecSFX,SizeOf(RecSFX));
        ProgressBarSfx.Max:=RecSFX.Size;
    finally
      ResourceStream.Free;
    end;

    ResourceStream:= TResourceStream.Create(0,'SFXDATA',RT_RCDATA);
    try
      ProgressBarSfx.Max:=ResourceStream.Size;
      FileNameDest   := EditPath.Text+ChangeFileExt(ExtractFileName(ParamStr(0)),'');
      DestFileStream := TFileStream.Create(FileNameDest,fmCreate);
      try
        DeCompressStream:=TDeCompressionStream.Create(ResourceStream);
        DeCompressStream.OnProgress:=DoProgress;
        try
           DestFileStream.CopyFrom(DeCompressStream,RecSFX.Size);
        finally
          DeCompressStream.Free;
        end;
      finally
        DestFileStream.Free;
      end;
    finally
      ResourceStream.Free;
    end;
 except on e : exception do
   Application.MessageBox(PAnsiChar(e.Message),'Error',MB_OK+MB_ICONERROR);
 end;
end;

procedure TFrmMain.ButtonExtractClick(Sender: TObject);
begin
  Extract;
end;

procedure TFrmMain.ButtonSelDirClick(Sender: TObject);
var
  Path: String;
begin
  Path:=EditPath.Text;
   if SelectFolder(Handle,'Select the output directory',Path) then
    EditPath.Text:=IncludeTrailingPathDelimiter(Path);
end;

procedure TFrmMain.DoProgress(Sender: TObject);
begin
   ProgressBarSfx.Position:=TCustomZLibStream(Sender).Position;
end;

procedure TFrmMain.FormCreate(Sender: TObject);
begin
  EditPath.Text:=IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)));
end;

end.

Project CreateSFX

unit MainCreateSFX;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, ZLib;

type
  TFrmCreateSFX = class(TForm)
    ButtonCreateSFX: TButton;
    OpenDialog1: TOpenDialog;
    EditFile: TEdit;
    ButtonSelect: TButton;
    ProgressBarSfx: TProgressBar;
    LabelInfo: TLabel;
    Label1: TLabel;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    RadioButton3: TRadioButton;
    RadioButton4: TRadioButton;
    procedure ButtonCreateSFXClick(Sender: TObject);
    procedure ButtonSelectClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    FSrcFileName   : string;
    FSfxFileName   : string;
    function  CreateStub:Boolean;
    function  GetCompressionLevel: TCompressionLevel;
    procedure CreateSFX;
    procedure DoProgress(Sender: TObject);
  end;

var
  FrmCreateSFX: TFrmCreateSFX;

implementation

uses Common;

{$R *.dfm}
{$R Stub.res}

procedure TFrmCreateSFX.ButtonCreateSFXClick(Sender: TObject);
begin
  if CreateStub then
   CreateSFX;
end;

procedure TFrmCreateSFX.ButtonSelectClick(Sender: TObject);
begin
   if OpenDialog1.Execute(Handle) then
   begin
     EditFile.Text:=OpenDialog1.FileName;
     FSrcFileName:=OpenDialog1.FileName;
     FSfxFileName:=ExtractFilePath(ParamStr(0))+ExtractFileName(EditFile.Text)+'.exe';
     ButtonCreateSFX.Enabled:=True;
     ButtonSelect.Enabled:=False;
   end;
end;

procedure TFrmCreateSFX.CreateSFX;
var
  SrcFileStream   : TFileStream;
  CompressedStream: TMemoryStream;
  hDestRes        : THANDLE;
  Compressor      : TCompressionStream;
  RecSFX          : TRecSFX;
begin
  SrcFileStream      := TFileStream.Create(FSrcFileName,fmOpenRead or fmShareDenyNone);
  ProgressBarSfx.Max := SrcFileStream.Size;
 try
  try
    CompressedStream:= TMemoryStream.Create;
    try
      Compressor:=TCompressionStream.Create(GetCompressionLevel,CompressedStream);
      try
        Compressor.OnProgress:=DoProgress;
        Compressor.CopyFrom(SrcFileStream,0);
      finally
        Compressor.Free;
      end;

        FillChar(RecSFX,SizeOf(RecSFX),#0);
        RecSFX.Size:=SrcFileStream.Size;
        Move(ExtractFileName(FSrcFileName)[1],RecSFX.Name,Length(ExtractFileName(FSrcFileName)));

        hDestRes:= BeginUpdateResource(PAnsiChar(FSfxFileName), False);
        if hDestRes <> 0 then
          if UpdateResource(hDestRes, RT_RCDATA,'SFXREC',0,@RecSFX,SizeOf(RecSFX)) then
             if EndUpdateResource(hDestRes,FALSE) then
             else
             RaiseLastOSError
          else
          RaiseLastOSError
        else
        RaiseLastOSError;

        hDestRes:= BeginUpdateResource(PAnsiChar(FSfxFileName), False);
        if hDestRes <> 0 then
          if UpdateResource(hDestRes, RT_RCDATA,'SFXDATA',0,CompressedStream.Memory,CompressedStream.Size) then
            if EndUpdateResource(hDestRes,FALSE) then
            begin
               LabelInfo.Caption:=
               Format('SFX Created %sOriginal Size %s %sCompressed Size %s Ratio %n %%',[#13,FormatFloat('#,',SrcFileStream.Size),#13,FormatFloat('#,',CompressedStream.Size),CompressedStream.Size*100/SrcFileStream.Size]);
               ProgressBarSfx.Position:=ProgressBarSfx.Max;
               ButtonCreateSFX.Enabled:=False;
            end
            else
            RaiseLastOSError
          else
          RaiseLastOSError
        else
        RaiseLastOSError;
    finally
      CompressedStream.Free;
    end;
  finally
    SrcFileStream.Free;
  end;
 except on e : exception do
   Application.MessageBox(PAnsiChar(e.Message),'Error',MB_OK+MB_ICONERROR);
 end;
end;

function TFrmCreateSFX.CreateStub:Boolean;
var
  StubStream: TResourceStream;
begin
  StubStream := TResourceStream.Create( HInstance, 'STUB', 'RT_RCDATA');
  try
     DeleteFile(FSfxFileName);
     StubStream.SaveToFile(FSfxFileName);
  finally
    StubStream.Free;
  end;
  Result:=FileExists(FSfxFileName);
end;

procedure TFrmCreateSFX.DoProgress(Sender: TObject);
begin
   ProgressBarSfx.Position:=TCustomZLibStream(Sender).Position;
   LabelInfo.Caption:=Format('Compressed %s bytes %n %%',[FormatFloat('#,',TCustomZLibStream(Sender).Position),100*TCustomZLibStream(Sender).Position/ProgressBarSfx.Max]);
   LabelInfo.Update;
end;

procedure TFrmCreateSFX.FormCreate(Sender: TObject);
begin
   LabelInfo.Caption:='';
end;

function TFrmCreateSFX.GetCompressionLevel: TCompressionLevel;
var
 i : Integer;
begin
  Result:=clMax;
    for i:= 0 to ComponentCount - 1 do
     if Components[i].ClassType = TRadioButton then
      if TRadioButton(Components[i]).Checked then
       Result:=TCompressionLevel(TRadioButton(Components[i]).Tag);
end;

end.

Notes:

* You can improve the final results if your rewrite the stub application using a library like KOL or avoid the use of the VCL using the WINAPI, to reduce the final exe size.

* These samples applications are for educational purposes only and not pretend be an alternative to another professional tools to generate a SFX file.

* The concept discussed in this entry can help you to build compressed and encrypted files using your own logic.

Check the full sourcecode on Github


5 Comments

Showing the location of the open TCP connections of my computer on a Web Map

I’ve been looking for more applications for the ip geolocation. so I wrote this small tool wich show the open remote tcp connections location on a Web Map (Google Maps, Bing Maps, Yahoo Maps and OpenStreetMap).

DISCLAIMER
This application is only for educational purposes. because some maps services does not allow to display content from a desktop application.

Check the screenshots samples

Showing the location of a ip address in Google Maps

Showing the location of a ip address in Yahoo Maps

Showing the location of a ip address in Bing Maps

Showing the location of a ip address in OpenStreet Maps

First we need obtain the current tcp connections, to do this we can use the GetExtendedTcpTable function wich is part of the iphlpapi.dll.

the header declaration goes like this

type
   TCP_TABLE_CLASS = Integer;

  PMibTcpRowOwnerPid = ^TMibTcpRowOwnerPid;
  TMibTcpRowOwnerPid  = packed record
    dwState     : DWORD;
    dwLocalAddr : DWORD;
    dwLocalPort : DWORD;
    dwRemoteAddr: DWORD;
    dwRemotePort: DWORD;
    dwOwningPid : DWORD;
    end;

  PMIB_TCPTABLE_OWNER_PID  = ^MIB_TCPTABLE_OWNER_PID;
  MIB_TCPTABLE_OWNER_PID = packed record
   dwNumEntries: DWord;
   table: array [0..ANY_SIZE - 1] OF TMibTcpRowOwnerPid;
  end;

var
   GetExtendedTcpTable:function  (pTcpTable: Pointer; dwSize: PDWORD; bOrder: BOOL; lAf: ULONG; TableClass: TCP_TABLE_CLASS; Reserved: ULONG): DWord; stdcall;

To use this function we need to determine size of the TcpTable returned, to allocate the memory. (look the first parameter is set to nil)

      TableSize := 0;
      Error := GetExtendedTcpTable(nil, @TableSize, False, AF_INET, TCP_TABLE_OWNER_PID_ALL, 0);
      if Error <> ERROR_INSUFFICIENT_BUFFER then
         Exit;

Now in the TableSize variable we have the size of the TcpTable, so we can retrieve the tcp info passing in the first parameter the buffer to contain the data

var
FExtendedTcpTable : PMIB_TCPTABLE_OWNER_PID;

 GetMem(FExtendedTcpTable, TableSize);
 GetExtendedTcpTable(FExtendedTcpTable, @TableSize, TRUE, AF_INET, TCP_TABLE_OWNER_PID_ALL, 0)

this is the full code to fill the listview with the tcp connections

procedure LoadTCPConnections;
var
   Server       : Cardinal;
   Error        : DWORD;
   TableSize    : DWORD;
   Snapshot     : THandle;
   i            : integer;
   ListItem     : TListItem;
   IpAddress    : in_addr;
   FCurrentPid  : Cardinal;
   IsLocal      : Boolean;
   RemoteIp     : string;
begin
   ListViewIPaddress.Items.BeginUpdate;
   try
     ListViewIPaddress.Items.Clear;
     FCurrentPid:=GetCurrentProcessId();
     FExternalIpAddress:=GetExternalIP;
      TableSize := 0;
      Error := GetExtendedTcpTable(nil, @TableSize, False, AF_INET, TCP_TABLE_OWNER_PID_ALL, 0);  //get the size of the TcpTable
      if Error <> ERROR_INSUFFICIENT_BUFFER then
         Exit;
      try
         GetMem(FExtendedTcpTable, TableSize);
         SnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); //take a Snapshot of the running process to obtain the exe name of the pid associated
         if GetExtendedTcpTable(FExtendedTcpTable, @TableSize, TRUE, AF_INET, TCP_TABLE_OWNER_PID_ALL, 0) = NO_ERROR then
            for i := 0 to FExtendedTcpTable.dwNumEntries - 1 do // for each record in the tcptable

            //avoid show connections of the current application and system connections (PID=0)
            if (FExtendedTcpTable.Table[i].dwOwningPid<>0) and (FExtendedTcpTable.Table[i].dwOwningPid<>FCurrentPid) and (FExtendedTcpTable.Table[i].dwRemoteAddr<>0) then
            begin
               IpAddress.s_addr := FExtendedTcpTable.Table[i].dwRemoteAddr;
               RemoteIp  := string(inet_ntoa(IpAddress));
               Server     :=  FExtendedTcpTable.Table[i].dwRemoteAddr;
               //determine if the remote ip is local or not
               IsLocal    := (FLocalIpAddresses.IndexOf(RemoteIp)>=0) or (Server=0) or (Server=16777343);

               if CheckBoxRemote.Checked and IsLocal then Continue;
               if FExtendedTcpTable.Table[i].dwRemoteAddr = 0 then
               FExtendedTcpTable.Table[i].dwRemotePort := 0;
               //Fill the Listview
               ListItem:=ListViewIPaddress.Items.Add;

               ListItem.ImageIndex:=-1;
               ListItem.Caption:=IntToStr(FExtendedTcpTable.Table[i].dwOwningPid);
               ListItem.SubItems.Add(GetPIDName(SnapShot,FExtendedTcpTable.Table[i].dwOwningPid));
               ListItem.SubItems.Add('TCP');
               ListItem.SubItems.Add(FLocalComputerName);

               IpAddress.s_addr := FExtendedTcpTable.Table[i].dwLocalAddr;
               ListItem.SubItems.Add(string(inet_ntoa(IpAddress))); //get the local ip address
               ListItem.SubItems.Add(IntToStr(ntohs(FExtendedTcpTable.Table[i].dwLocalPort)));

               ListItem.SubItems.AddObject('',Pointer(FExtendedTcpTable.Table[i].dwRemoteAddr));

               ListItem.SubItems.Add(RemoteIp);
               ListItem.SubItems.Add(IntToStr(ntohs(FExtendedTcpTable.Table[i].dwRemotePort)));
               ListItem.SubItems.Add(MIB_TCP_STATE[FExtendedTcpTable.Table[i].dwState]);

               ListItem.SubItems.Add('');
               ListItem.SubItems.Add('');
               ListItem.SubItems.Add('');
               ListItem.SubItems.Add('');
            end;

      finally
         FreeMem(FExtendedTcpTable);
      end;

   finally
    ListViewIPaddress.Items.EndUpdate;
   end;
    //now for resolve the server location and show the flag icon we run a tthread for each row in the listview
    for i:= 0 to ListViewIPaddress.Items.Count-1 do
    begin
      Server:=Cardinal(ListViewIPaddress.Items.Item[i].SubItems.Objects[COLUMN_RemoteServer]);
      IsLocal    := (FLocalIpAddresses.IndexOf(ListViewIPaddress.Items.Item[i].SubItems[COLUMN_RemoteIP])>=0) or (Server=0) or (Server=16777343);
      if not IsLocal then
        TResolveServerName.Create(Server,ListViewIPaddress.Items.Item[i].SubItems[COLUMN_RemoteIP],ImageList1,ListViewIPaddress.Items.Item[i]);
    end;
end;

The code of the thread for resolve the ip locations and retrieve the flags images.

type
   TResolveGeoLocation = class(TThread)
   private
     FListItem         : TListItem;
     FGeoInfo          : TGeoInfoClass;
     FRemoteHostName   : string;
     FRemoteIP         : string;
     FServer           : Cardinal;
     FImageList        : TImageList;
     procedure SetData;
   protected
     procedure Execute; override;
     constructor Create(Server : Cardinal;const RemoteIP:string;ImageList:TImageList;ListItem:TListItem);
   end;

constructor TResolveGeoLocation.Create(Server: Cardinal;const RemoteIP:string;ImageList:TImageList;ListItem:TListItem);
begin
   inherited Create(False);
   FServer   :=Server;
   FRemoteIP :=RemoteIP;
   FImageList:=ImageList;
   FListItem :=ListItem;
   FreeOnTerminate := True;
end;

procedure TResolveGeoLocation.Execute;
begin
  FreeOnTerminate := True;
  FRemoteHostName := GetRemoteHostName(FServer);
  FGeoInfo:=TGeoInfoClass.Create(FRemoteIP);
  try
   Synchronize(SetData);
  finally
   FGeoInfo.Free;
  end;
end;

procedure TResolveGeoLocation.SetData;
var
   Bitmap  : TBitmap;
begin
    FListItem.SubItems[COLUMN_RemoteServer]:=FRemoteHostName;
    FListItem.SubItems[COLUMN_Country]     :=FGeoInfo.GeoInfo.CountryName;
    FListItem.SubItems[COLUMN_City]        :=FGeoInfo.GeoInfo.City;
    FListItem.SubItems[COLUMN_Latitude]    :=FGeoInfo.GeoInfo.LatitudeToString;
    FListItem.SubItems[COLUMN_Longitude]   :=FGeoInfo.GeoInfo.LongitudeToString;

    if Assigned(FGeoInfo.GeoInfo.FlagImage) then
    begin
       Bitmap := TBitmap.Create;
      try
        Bitmap.Assign(FGeoInfo.GeoInfo.FlagImage);
        if (Bitmap.Width=FImageList.Width) and ((Bitmap.Height=FImageList.Height)) then
         FListItem.ImageIndex:=FImageList.Add(Bitmap,nil)
        else
         Bitmap.Width;
      finally
        Bitmap.Free;
      end;
    end;

    FListItem.MakeVisible(False);
end;

Now the class to obtain the geolocation info and the flag of the country.

type
 PGeoInfo   = ^TGeoInfo;
 TGeoInfo   = record
  Status        : string;
  CountryCode   : string;
  CountryName   : string;
  RegionCode    : string;
  City          : string;
  ZipPostalCode : string;
  Latitude      : Double;
  Longitude     : Double;
  TimezoneName  : string;
  Gmtoffset     : string;
  Isdst         : string;
  FlagImage     : TPngImage;
  function LatitudeToString:string;
  function LongitudeToString:string;
 end;

 TGeoInfoClass = class
 private
    FIpAddress : string;
    FGeoInfo   : TGeoInfo;
 public
  property  GeoInfo : TGeoInfo read FGeoInfo;
  constructor Create(IpAddress : string); overload;
  Destructor  Destroy; override;
 end;

and the new function to retrieve the geolocation data from ipinfodb.com

procedure GetGeoInfo(const IpAddress : string;var GeoInfo :TGeoInfo);
var
  XMLDoc        : OleVariant;
  ANode         : OleVariant;
  FormatSettings: TFormatSettings;
  d             : Double;
  Success       : HResult;
  UrlImage      : string;
  XmlContent    : string;
  StreamData    : TMemoryStream;
begin
  GeoInfo.FlagImage:=nil;
  Success := CoInitializeEx(nil, COINIT_MULTITHREADED);
  try
      XmlContent:=WinInet_HttpGet(Format(UrlGeoLookupInfo,[IpAddress]));
      if XmlContent<>'' then
      begin
          XMLDoc := CreateOleObject('Msxml2.DOMDocument.6.0');
          XMLDoc.async := false;
          XMLDoc.LoadXML(XmlContent);
          XMLDoc.setProperty('SelectionLanguage','XPath');
          ANode:=XMLDoc.selectSingleNode('/Response/Status');
          if not VarIsNull(ANode) then GeoInfo.Status:=ANode.Text;
          ANode:=XMLDoc.selectSingleNode('/Response/CountryCode');
          if not VarIsNull(ANode) then GeoInfo.CountryCode:=ANode.Text;
          ANode:=XMLDoc.selectSingleNode('/Response/CountryName');
          if not VarIsNull(ANode) then GeoInfo.CountryName:=ANode.Text;
          ANode:=XMLDoc.selectSingleNode('/Response/RegionCode');
          if not VarIsNull(ANode) then GeoInfo.RegionCode:=ANode.Text;
          ANode:=XMLDoc.selectSingleNode('/Response/City');
          if not VarIsNull(ANode) then GeoInfo.City:=ANode.Text;
          ANode:=XMLDoc.selectSingleNode('/Response/ZipPostalCode');
          if not VarIsNull(ANode) then GeoInfo.ZipPostalCode:=ANode.Text;

          ANode:=XMLDoc.selectSingleNode('/Response/Latitude');
          if not VarIsNull(ANode) then
          begin
            FormatSettings.DecimalSeparator:='.';
            d:=StrToFloat(ANode.Text,FormatSettings);
            GeoInfo.Latitude:=d;
          end;

          ANode:=XMLDoc.selectSingleNode('/Response/Longitude');
          if not VarIsNull(ANode) then
          begin
            FormatSettings.DecimalSeparator:='.';
            d:=StrToFloat(ANode.Text,FormatSettings);
            GeoInfo.Longitude:=d;
          end;

          ANode:=XMLDoc.selectSingleNode('/Response/TimezoneName');
          if not VarIsNull(ANode) then GeoInfo.TimezoneName:=ANode.Text;
          ANode:=XMLDoc.selectSingleNode('/Response/Gmtoffset');
          if not VarIsNull(ANode) then GeoInfo.Gmtoffset:=ANode.Text;
          ANode:=XMLDoc.selectSingleNode('/Response/Isdst');
          if not VarIsNull(ANode) then GeoInfo.Isdst:=ANode.Text;
      end;
  finally
    case Success of
      S_OK, S_FALSE: CoUninitialize;
    end;
  end;

  if GeoInfo.CountryCode<>'' then //get the image
  begin
    GeoInfo.FlagImage  := TPngImage.Create;
    StreamData         := TMemoryStream.Create;
    try
       UrlImage:=Format(UrlFlags,[LowerCase(GeoInfo.CountryCode)]);
          WinInet_HttpGet(UrlImage,StreamData);
          if StreamData.Size>0 then
          begin
            StreamData.Seek(0,0);
            try
              GeoInfo.FlagImage.LoadFromStream(StreamData);//load the image in a Stream
            except   //the image is not valid
              GeoInfo.FlagImage.Free;
              GeoInfo.FlagImage:=nil;
            end;
          end;
    finally
      StreamData.Free;
    end;
  end;

end;

The part of the maps is easy, just only need load a html page in a Twebbrowser with the Latitude and longitude to show in the current selected map

procedure GetMapListItem();
var
 HTMLWindow2  : IHTMLWindow2;
 MemoryStream : TMemoryStream;
 Item         : TListItem;
 Lat          : AnsiString;
 Lng          : AnsiString;
 Title        : AnsiString;
 MapType      : string;
 MapStr       : AnsiString;

//sorry , but the html pages contains a lot of % (porcent) chars
function ReplaceTag(const PageStr,Tag,NewValue:string):AnsiString;
begin
   Result:=AnsiString(StringReplace(PageStr,Tag,NewValue,[rfReplaceAll]));
end;

begin
    Item:=ListViewIPaddress.Selected;
    if not Assigned(Item) then  exit;
    if Item.SubItems.Count<COLUMN_Latitude then Exit;
    if Item.SubItems[COLUMN_Latitude]='' then Exit;

    Lat:=AnsiString(Item.SubItems[COLUMN_Latitude]);
    Lng:=AnsiString(Item.SubItems[COLUMN_Longitude]);
    Title:=AnsiString(Format('(%s,%s) %s - %s',[Lat,Lng,Item.SubItems[COLUMN_RemoteServer],Item.SubItems[COLUMN_RemoteIP]]));
    MapType:=ComboBoxTypes.Text;

   WebBrowser1.Navigate('about:blank');
   while WebBrowser1.ReadyState < READYSTATE_INTERACTIVE do
    Application.ProcessMessages;

    if Assigned(WebBrowser1.Document) then
    begin
      MemoryStream := TMemoryStream.Create;
      try
        case FCurrentMapType of
          Google_Maps    : MapStr:=GoogleMapsPage;
          Yahoo_Map      : MapStr:=YahooMapsPage;
          Bing_Map       : MapStr:=BingsMapsPage;
          Open_Streetmap : MapStr:=OpenStreetMapsPage;
        end;

        MapStr:=ReplaceTag(MapStr,'[Lat]',Lat);
        MapStr:=ReplaceTag(MapStr,'[Lng]',Lng);
        MapStr:=ReplaceTag(MapStr,'[Title]',Title);
        MapStr:=ReplaceTag(MapStr,'[Type]',MapType);
        MemoryStream.WriteBuffer(Pointer(MapStr)^, Length(MapStr));

        MemoryStream.Seek(0, soFromBeginning);
        (WebBrowser1.Document as IPersistStreamInit).Load(TStreamAdapter.Create(MemoryStream));
      finally
         MemoryStream.Free;
      end;
      HTMLWindow2 := (WebBrowser1.Document as IHTMLDocument2).parentWindow;
    end;
end;

and finally the html code embedded in a delphi const string for each map type

const
GoogleMapsPage: AnsiString =
'<html> '+
'<head> '+
'<meta name="viewport" content="initial-scale=1.0, user-scalable=yes" /> '+
'<script type="text/javascript" src="http://maps.google.com/maps/api/js?sensor=true"></script> '+
'<script type="text/javascript"> '+
'  var map;'+
'  function initialize() { '+
'    geocoder = new google.maps.Geocoder();'+
'    var latlng = new google.maps.LatLng([Lat],[Lng]); '+
'    var myOptions = { '+
'      zoom: 12, '+
'      center: latlng, '+
'      mapTypeId: google.maps.MapTypeId.[Type] '+
'    }; '+
'    map = new google.maps.Map(document.getElementById("map_canvas"), myOptions); '+
'    var marker = new google.maps.Marker({'+
'      position: latlng, '+
'      title: "[Title]", '+
'      map: map '+
'  });'+
'  } '+
''+'</script> '+
'</head> '+
'<body onload="initialize()"> '+
'  <div id="map_canvas" style="width:100%; height:100%"></div> '+
'</body>'+
'</html>';

YahooMapsPage: AnsiString =
'<html> '+
'<head> '+
'<meta name="viewport" content="initial-scale=1.0, user-scalable=yes" /> '+
'<script type="text/javascript" src="http://api.maps.yahoo.com/ajaxymap?v=3.8&amp;appid=08gJIU7V34H9WlTSGrIyEIb73GLT5TpAaF2HzOSJIuTO2AVn6qzftRPDQtcQyynObIG8"></script> '+
'<script type="text/javascript"> '+
'  function initialize() '+
'{'+
'  var map = new YMap ( document.getElementById ( "map_canvas" ) );'+
'  map.addTypeControl();'+
'  map.addZoomLong(); '+
'  map.addPanControl();'+
'	 map.setMapType ( YAHOO_MAP_[Type] );'+
'	 var geopoint = new YGeoPoint ( [Lat] , [Lng] ); '+
'	 map.drawZoomAndCenter ( geopoint , 5 );'+
'  var newMarker= new YMarker(geopoint); '+
'  var markerMarkup = "[Title]";'+
'	 newMarker.openSmartWindow(markerMarkup);'+
'	 map.addOverlay(newMarker);'+
'}'+
''+'</script> '+
'</head> '+
'<body onload="initialize()"> '+
'  <div id="map_canvas" style="width:100%; height:100%"></div> '+
'</body>'+
'</html>';

BingsMapsPage: AnsiString =
'<html> '+
'<head> '+
'<meta name="viewport" content="initial-scale=1.0, user-scalable=yes" /> '+
'<script type="text/javascript" src="http://dev.virtualearth.net/mapcontrol/mapcontrol.ashx?v=6.2"></script> '+
'<script type="text/javascript"> '+
'var map = null; '+
'  function initialize() '+
'{'+
'        map = new VEMap("map_canvas"); '+
'        map.LoadMap(new VELatLong([Lat],[Lng]), 10 ,"h" ,false);'+
'        map.SetMapStyle(VEMapStyle.[Type]);'+
'        map.ShowMiniMap((document.getElementById("map_canvas").offsetWidth - 180), 200, VEMiniMapSize.Small);'+
'        map.SetZoomLevel (12);'+
'	       shape = new VEShape(VEShapeType.Pushpin, map.GetCenter()); '+
'	       shape.SetTitle("[Title]");'+
'	       map.AddShape ( shape );'+
'}'+
''+'</script> '+
'</head> '+
'<body onload="initialize()"> '+
'  <div id="map_canvas" style="width:100%; height:100%"></div> '+
'</body>'+
'</html>';

OpenStreetMapsPage: AnsiString =
'<html> '+
'<head> '+
'<meta name="viewport" content="initial-scale=1.0, user-scalable=yes" /> '+
'<script src="http://www.openlayers.org/api/OpenLayers.js"></script> '+
'<script type="text/javascript"> '+
'  function initialize() '+
'{'+
'    map = new OpenLayers.Map("map_canvas");'+
'    map.addLayer(new OpenLayers.Layer.OSM()); '+
'    var lonLat = new OpenLayers.LonLat( [Lng] , [Lat] ) '+
'          .transform( '+
'            new OpenLayers.Projection("EPSG:4326"), '+
'            map.getProjectionObject() '+
'          ); '+
'    var zoom=16; '+
'    var markers = new OpenLayers.Layer.Markers( "Markers" );  '+
'    map.addLayer(markers); '+
'    markers.addMarker(new OpenLayers.Marker(lonLat)); '+
'    map.setCenter (lonLat, zoom); '+
'}'+
''+'</script> '+
'</head> '+
'<body onload="initialize()"> '+
'  <div id="map_canvas" style="width:100%; height:100%"></div> '+
'</body>'+
'</html>';

Check the full source code on Github


7 Comments

Building a traceroute application with IP geolocation using Delphi

Using the free service of ip geolocation provided by http://ipinfodb.com/ , you can do very cool things.

See this sample wich intregrates a trace route and the ip geolocation, to obtain the location of every server included in the trace of an ip address.

First we define the stucture to contain the geolocation data

type
 TGeoInfo   = record
  Status        : string;
  CountryCode   : string;
  CountryName   : string;
  RegionCode    : string;
  City          : string;
  ZipPostalCode : string;
  Latitude      : double;
  Longitude     : double;
  TimezoneName  : string;
  Gmtoffset     : string;
  Isdst         : string;
  function LatitudeToString:string;
  function LongitudeToString:string;
 end;

function TGeoInfo.LatitudeToString: string; //this helper function retrieve the latitute as a string, forcing the decimal separator to a dot
var
  FormatSettings: TFormatSettings;
begin
  FormatSettings.DecimalSeparator:='.';
  result:=FloatToStr(Latitude,FormatSettings);
end;

function TGeoInfo.LongitudeToString: string;//this helper function retrieve the longitude as a string, forcing the decimal separator to a dot
var
  FormatSettings: TFormatSettings;
begin
  FormatSettings.DecimalSeparator:='.';
  result:=FloatToStr(Longitude,FormatSettings);
end;

Now the function to retrieve the geolocation, the url was updated to use the new api published the 2010-11-15.

const
//the key used in this link if only for demo purposes, create your own free key registering in http://ipinfodb.com/
 UrlGeoLookupInfo  ='http://api.ipinfodb.com/v2/ip_query.php?key=a069ef201ef4c1b61231b3bdaeb797b5488ef879effb23d269bda3a572dc704c&ip=%s&timezone=true';

procedure GetGeoInfo(const IpAddress : string;var GeoInfo :TGeoInfo);
var
  lHTTP         : TIdHTTP;
  lStream       : TStringStream;
  XMLDoc        : OleVariant;
  ANode         : OleVariant;
  FormatSettings: TFormatSettings;
  d             : Double;
  Success       : HResult;
begin
  lHTTP   := TIdHTTP.Create(nil);
  lStream := TStringStream.Create('');
  Success := CoInitializeEx(nil, COINIT_MULTITHREADED);//necesary to support MULTITHREAD
  try
      lHTTP.Get(Format(UrlGeoLookupInfo,[IpAddress]), lStream);
      lStream.Seek(0,soFromBeginning);
      XMLDoc := CreateOleObject('Msxml2.DOMDocument.6.0');
      XMLDoc.async := false;
      XMLDoc.LoadXML(lStream.ReadString(lStream.Size));
      XMLDoc.setProperty('SelectionLanguage','XPath');
      ANode:=XMLDoc.selectSingleNode('/Response/Status');
      if not VarIsNull(ANode) then GeoInfo.Status:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/CountryCode');
      if not VarIsNull(ANode) then GeoInfo.CountryCode:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/CountryName');
      if not VarIsNull(ANode) then GeoInfo.CountryName:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/RegionCode');
      if not VarIsNull(ANode) then GeoInfo.RegionCode:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/City');
      if not VarIsNull(ANode) then GeoInfo.City:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/ZipPostalCode');
      if not VarIsNull(ANode) then GeoInfo.ZipPostalCode:=ANode.Text;

      ANode:=XMLDoc.selectSingleNode('/Response/Latitude');
      if not VarIsNull(ANode) then
      begin
        FormatSettings.DecimalSeparator:='.';
        d:=StrToFloat(ANode.Text,FormatSettings);
        GeoInfo.Latitude:=d;
      end;

      ANode:=XMLDoc.selectSingleNode('/Response/Longitude');
      if not VarIsNull(ANode) then
      begin
        FormatSettings.DecimalSeparator:='.';
        d:=StrToFloat(ANode.Text,FormatSettings);
        GeoInfo.Longitude:=d;
      end;

      ANode:=XMLDoc.selectSingleNode('/Response/TimezoneName');
      if not VarIsNull(ANode) then GeoInfo.TimezoneName:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/Gmtoffset');
      if not VarIsNull(ANode) then GeoInfo.Gmtoffset:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/Isdst');
      if not VarIsNull(ANode) then GeoInfo.Isdst:=ANode.Text;
  finally
    lHTTP.Free;
    lStream.Free;
    case Success of
      S_OK, S_FALSE: CoUninitialize;
    end;
  end;
end;

Now using the IcmpCreateFile,IcmpCloseHandle and IcmpSendEcho functions we can write a trace route function.

function IcmpCreateFile: THandle; stdcall; external 'ICMP.DLL' name 'IcmpCreateFile';
function IcmpCloseHandle(IcmpHandle: THandle): BOOL; stdcall;  external 'ICMP.DLL' name 'IcmpCloseHandle';
function IcmpSendEcho(IcmpHandle : THandle; DestinationAddress: Longint;  RequestData: Pointer; RequestSize: Word; RequestOptions: PIP_option_information; ReplyBuffer: Pointer; ReplySize, Timeout: DWORD): DWORD; stdcall;  external 'ICMP.DLL' name 'IcmpSendEcho';

Check the definition of the TGeoTraceThread TThread

  ProcTraceCallBack    = procedure(const ServerName,ServerIp:string) of object;
  ProcTraceLogCallBack = procedure(const Msg:string) of object;
  TGeoTraceThread = class(TThread)
  private
    DestAddr            : in_addr;
    TraceHandle         : THandle;
    FDestAddress        : string;
    FLogString          : string;
    FIcmpTimeOut        : Word;
    FMaxHops            : Word;
    FResolveHostName    : boolean;
    FServerCallBack     : string;
    FServerIpCallBack   : string;
    FCallBack           : ProcTraceCallBack;
    FLogCallBack        : ProcTraceLogCallBack;
    FIncludeGeoInfo     : boolean;
    FGeoInfo            : TGeoInfo;
    function  Trace(const Ttl: Byte): Longint;
    procedure Log;
    procedure IntCallBack;
  public
    procedure Execute; override;
    property  MaxHops : Word read FMaxHops write FMaxHops default 30;
    property  DestAddress : string read FDestAddress write FDestAddress;
    property  IcmpTimeOut : Word read FIcmpTimeOut write FIcmpTimeOut default 5000;
    property  ResolveHostName : boolean read FResolveHostName write FResolveHostName default True;
    property  IncludeGeoInfo : boolean read FIncludeGeoInfo write FIncludeGeoInfo default True;
    property  CallBack : ProcTraceCallBack read FCallBack write FCallBack;
    property  MsgCallBack : ProcTraceLogCallBack read FLogCallBack write FLogCallBack;
  end;

and now the implementation of the TGeoTraceThread TThread, the code was commented to explain the logic of the trace route.

procedure TGeoTraceThread.Execute;
const
  MaxPings = 3;
var
  HostName   : String;
  HostReply  : Boolean;
  HostIP     : LongInt;
  HostEnt    : PHostEnt;
  WSAData    : TWSAData;
  WsaErr     : DWORD;
  OldTick    : DWORD;
  PingTime   : DWORD;
  TraceResp  : Longint;
  Index      : Word;
  FCurrentTTL: Word;
  sValue     : string;
  FGeoInfoStr: string;
  IpAddress  : in_addr;
begin

  WsaErr := WSAStartup($101, WSAData);
  if WsaErr <> 0 then
  begin
    FLogString := SysErrorMessage(WSAGetLastError);
    if Assigned(FLogCallBack)then Synchronize(Log);
    Exit;
  end;

  try
    HostEnt := gethostbyname(PAnsiChar(AnsiString(FDestAddress))); //get the host to trace
    if not Assigned(HostEnt) then
    begin
      FLogString := SysErrorMessage(WSAGetLastError);
      if Assigned(FLogCallBack) then Synchronize(Log);
      Exit;
    end;

    DestAddr     := PInAddr(in_addr(HostEnt.h_addr_list^))^; //get the address of the host to trace
    TraceHandle := IcmpCreateFile;

    if TraceHandle = INVALID_HANDLE_VALUE then
    begin
      FLogString := SysErrorMessage(GetLastError);
      if Assigned(FLogCallBack) then Synchronize(Log);
      Exit;
    end;

    try

      if Assigned(FLogCallBack)then //check if the callback function to log the data is assigned
      begin
        FLogString := Format('Tracing route to %s [%s]',[FDestAddress,string(inet_ntoa(DestAddr))]);
        Synchronize(Log); //Log the data
        FLogString := Format('over a maximum of %d hops ',[FMaxHops]);
        Synchronize(Log);//log the data
      end;

      TraceResp    := 0;
      FCurrentTTL  := 0;

      while (TraceResp <> DestAddr.S_addr) and (FCurrentTTL < FMaxHops) do //begin the trace
      begin
        Inc(FCurrentTTL);
        HostReply := False;
        sValue:='';
        for Index := 0 to MaxPings-1 do // make 3 pings to the current host
        begin
          OldTick   := GetTickCount; //save the current time
          TraceResp := Trace(FCurrentTTL); //do the trace

          if TraceResp = -1 then //check for the response of the trace, -1 indicate a request time-out
            FLogString := '    *    '
          else
          begin
            PingTime   :=GetTickCount - OldTick; //calculate the elapsed time in ms

            if PingTime>0 then
             FLogString := Format('%6d ms', [PingTime])
            else
             FLogString := Format('    <%d ms', [1]);

            HostReply := True;
            HostIP    := TraceResp;
          end;

          if Index = 0 then
            FLogString := Format('%3d %s', [FCurrentTTL, FLogString]);

          sValue:=sValue+FLogString;
        end;

        FLogString:=sValue+' ';

        if HostReply then
        begin
          IpAddress.s_addr :=HostIP;
          sValue :=string(inet_ntoa(IpAddress)); //get the ip address (x.x.x.x) of the current host

          FGeoInfoStr:='';
          if FIncludeGeoInfo then //makes the magic now
          begin
            GetGeoInfo(sValue,FGeoInfo); //get the geolocation info about the current host
            FGeoInfoStr:=Format('(%s,%s) %s-%s TimeZone %s',[FGeoInfo.LongitudeToString,FGeoInfo.LatitudeToString,FGeoInfo.CountryName,FGeoInfo.City,FGeoInfo.TimezoneName]); //construct the string to log the data
          end;

          FServerCallBack  :='';
          FServerIpCallBack:=sValue;
          if FResolveHostName then //only if the property ResolveHostName is Tru try to resolve the current host name
          begin
            HostName         := GetRemoteHostName(HostIP);
            FServerCallBack  := HostName;
            if HostName <> '' then
              FLogString := FLogString + HostName + ' [' + sValue + '] '+FGeoInfoStr
            else
              FLogString := FLogString + sValue +' '+ FGeoInfoStr;
          end
          else
          FLogString := FLogString + sValue+' '+ FGeoInfoStr;

          if Assigned(FCallBack) then Synchronize(IntCallBack);
        end
        else
          FLogString := FLogString+' Request timed out.';

        FLogString := '  ' + FLogString;
        if Assigned(FLogCallBack) then Synchronize(Log);
      end;

    finally
      IcmpCloseHandle(TraceHandle);
    end;

    if Assigned(FLogCallBack) then
    begin
      FLogString := 'Trace complete'; //we are done
      Synchronize(Log);
    end;

  finally
    WSACleanup;
  end;
end;

function TGeoTraceThread.Trace(const Ttl: Byte): Longint;
var
  IPOptionInfo: TIPOptionInformation;
  IcmpEcho    : PIcmpEchoReply;
  IcpmErr     : Integer;
begin
  GetMem(IcmpEcho, SizeOf(TIcmpEchoReply));
  try
    IPOptionInfo.Ttl         := Ttl;
    IPOptionInfo.Tos         := 0;
    IPOptionInfo.Flags       := 0;
    IPOptionInfo.OptionsSize := 0;
    IPOptionInfo.OptionsData := nil;

    IcpmErr := IcmpSendEcho(TraceHandle,DestAddr.S_addr,nil,0,@IPOptionInfo,IcmpEcho,SizeOf(TIcmpEchoReply),FIcmpTimeOut); //send the echo request and wait for any echo response replies
    if IcpmErr = 0 then //check for the reply
    begin
      Result := -1;
      Exit;
    end;
    Result := IcmpEcho.Address;
  finally
    FreeMem(IcmpEcho); //dispose the memory allocated
  end;
end;

procedure TGeoTraceThread.IntCallBack; //this callback function report the current server name and ip address
begin
  FCallBack(FServerCallBack,FServerIpCallBack);
end;

procedure TGeoTraceThread.Log; //this callback log the data
begin
  FLogCallBack(FLogString);
end;

finally you can call the the TGeoTraceThread class in this way

procedure TFrmMainTrace.TraceAddress;
var
  Trace : TGeoTraceThread;
begin
    if Trim(EditAddress.Text)='' then  Exit;
    Trace:=TGeoTraceThread.Create(True);
    Trace.FreeOnTerminate    :=True;
    Trace.DestAddress        :=EditAddress.Text;
    Trace.MaxHops            :=30; //hops
    Trace.ResolveHostName    :=True;
    Trace.IcmpTimeOut        :=5000; //timeout in ms
    Trace.MsgCallBack        :=TraceLogCallBack; //assign the callback
    Trace.IncludeGeoInfo     :=True; //set this property true option to display the geoloccation info result in the trace
    Trace.Start;
end;

procedure TFrmMainTrace.TraceLogCallBack(const Msg: string);
begin
  MemoTrace.Lines.Add(Msg);
  MemoTrace.Perform(WM_VSCROLL, SB_BOTTOM, 0);
end;

and the output look like this, check which the trace includes the latitude, longitude, timezone, country and city for each host included in the trace.

Tracing route to theroadtodelphi.wordpress.com [76.74.254.123]
over a maximum of 30 hops
    1     16 ms    <1 ms    <1 ms DD-WRT [192.168.1.2] (0,0) Reserved- TimeZone
    2     16 ms    <1 ms    16 ms 10.9.90.1 (0,0) Reserved- TimeZone
    3     <1 ms    16 ms    <1 ms sblx12gw.gtdinternet.com [190.196.63.126] (-70.6667,-33.45) Chile-Santiago TimeZone Chile/Continental
    4     <1 ms    16 ms    <1 ms 190.196.125.185 (-70.6667,-33.45) Chile-Santiago TimeZone Chile/Continental
    5     <1 ms    16 ms    <1 ms ci1.te1-2.v218.cn1.gtdinternet.com [190.196.124.74] (-70.6667,-33.45) Chile-Santiago TimeZone Chile/Continental
    6     <1 ms    16 ms    <1 ms ci2.te1-1.ci1.gtdinternet.com [201.238.238.26] (-70.6667,-33.45) Chile-Santiago TimeZone Chile/Continental
    7     16 ms    <1 ms    15 ms ge13-0-0.santiago2.san.seabone.net [195.22.221.85] (-70.6667,-33.45) Chile-Santiago TimeZone Chile/Continental
    8     *        *        *      Request timed out.
    9    109 ms   125 ms   109 ms pos0-15-1-0.miami13.mia.seabone.net [195.22.221.205] (-70.6667,-33.45) Chile-Santiago TimeZone Chile/Continental
   10    125 ms   109 ms   125 ms te7-2.miami7.mia.seabone.net [195.22.199.111] (-80.2939,25.7615) United States-Miami TimeZone America/New_York
   11    172 ms   187 ms   171 ms te-7-4.car2.Miami1.Level3.net [63.209.150.165] (-97,38) United States- TimeZone
   12    188 ms   187 ms   187 ms ae-31-51.ebr1.Miami1.Level3.net [4.69.138.94] (-97,38) United States- TimeZone
   13    172 ms   187 ms   171 ms ae-2-2.ebr1.Dallas1.Level3.net [4.69.140.133] (-97,38) United States- TimeZone
   14    171 ms   203 ms   187 ms ae-3-80.edge9.Dallas1.Level3.net [4.69.145.144] (-97,38) United States- TimeZone
   15    188 ms   171 ms   187 ms PEER-1-NETW.edge9.Dallas1.Level3.net [4.59.118.6] (-95.7402,29.1793) United States-West Columbia TimeZone America/Chicago
   16     *        *        *      Request timed out.
   17     *        *        *      Request timed out.
   18    187 ms   188 ms   187 ms wordpress.com [76.74.254.123] (-98.5353,29.4713) United States-San Antonio TimeZone America/Chicago
Trace complete

Check the source code on Github

(The demo project was compiled under Delphi XE, but the TGeoTraceThread class can be used with older versions of Delphi)


9 Comments

Getting IP address geolocation info with Delphi

ipinfodb.com provides a free service wich let you obtain geolocation info about any ip address. you can access this info parsing the content returned by this page.

the request must be done in this way

http://ipinfodb.com/ip_query.php?timezone=true&ip=204.236.220.71

UPDATE

The above url is not longer valid because to a New APIs are being introduced with API key. you must register in this site to get access to the info.

now you must use a url like this

http://api.ipinfodb.com/v2/ip_query.php?key=&ip=74.125.45.100&timezone=true

and the response look like this

<Response>
<Ip>204.236.220.71</Ip>
<Status>OK</Status>
<CountryCode>US</CountryCode>
<CountryName>United States</CountryName>
<RegionCode>53</RegionCode>
<RegionName>Washington</RegionName>
<City>Seattle</City>
<ZipPostalCode>98144</ZipPostalCode>
<Latitude>47.5839</Latitude>
<Longitude>-122.299</Longitude>
<TimezoneName>America/Los_Angeles</TimezoneName>
<Gmtoffset>-28800</Gmtoffset>
<Isdst>0</Isdst>
</Response>

Now using a TIdHTTP component you can get the result of the request to this page.

uses
  Classes,
  ComObj,
  Variants,
  IdHTTP,

type
 TGeoInfo   = record
  Status        : string;
  CountryCode   : string;
  CountryName   : string;
  RegionCode    : string;
  City          : string;
  ZipPostalCode : string;
  Latitude      : string;
  Longitude     : string;
  TimezoneName  : string;
  Gmtoffset     : string;
  Isdst         : string;
 end;

const
 UrlGeoLookupInfo  ='http://ipinfodb.com/ip_query.php?timezone=true&ip=%s';
 UrlGeoLookupInfo2 ='http://backup.ipinfodb.com/ip_query.php?timezone=true&ip=%s'; //backup server

procedure GetGeoInfo(const IpAddress : string;var GeoInfo :TGeoInfo);
var
  lHTTP  : TIdHTTP;
  lStream: TStringStream;
  XMLDoc : OleVariant;
  ANode  : OleVariant;
begin
  lHTTP   := TIdHTTP.Create(nil);
  lStream := TStringStream.Create;
  try
      try
        lHTTP.Get(Format(UrlGeoLookupInfo,[IpAddress]), lStream); //get the request
      except
        lHTTP.Get(Format(UrlGeoLookupInfo2,[IpAddress]), lStream); //if something is wrong try using the backup server.
      end;
      lStream.Seek(0,0);
      XMLDoc := CreateOleObject('Msxml2.DOMDocument.6.0');
      XMLDoc.async := false;
      XMLDoc.LoadXML(lStream.ReadString(lStream.Size));
      XMLDoc.setProperty('SelectionLanguage','XPath');//use XPath to parse the xml result
      ANode:=XMLDoc.selectSingleNode('/Response/Status');
      if not VarIsNull(ANode) then GeoInfo.Status:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/CountryCode');
      if not VarIsNull(ANode) then GeoInfo.CountryCode:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/CountryName');
      if not VarIsNull(ANode) then GeoInfo.CountryName:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/RegionCode');
      if not VarIsNull(ANode) then GeoInfo.RegionCode:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/City');
      if not VarIsNull(ANode) then GeoInfo.City:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/ZipPostalCode');
      if not VarIsNull(ANode) then GeoInfo.ZipPostalCode:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/Latitude');
      if not VarIsNull(ANode) then GeoInfo.Latitude:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/Longitude');
      if not VarIsNull(ANode) then GeoInfo.Longitude:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/TimezoneName');
      if not VarIsNull(ANode) then GeoInfo.TimezoneName:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/Gmtoffset');
      if not VarIsNull(ANode) then GeoInfo.Gmtoffset:=ANode.Text;
      ANode:=XMLDoc.selectSingleNode('/Response/Isdst');
      if not VarIsNull(ANode) then GeoInfo.Isdst:=ANode.Text;
  finally
    lHTTP.Free;
    lStream.Free;
  end;
end;


12 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

the source code (Delphi 2007) is available on Github.


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 https://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 https://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.


21 Comments

WMI Delphi Code Creator

UPDATE

The new page of this project is hosted in Github.

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 this code. Tested on Delphi 2007, Delphi 2010, Delphi XE – (Windows XP/7/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;