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.

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('http://theroadtodelphi.wordpress.com/'));
     Readln;
  except
    on E:Exception do
      Writeln(E.Classname, ': ', E.Message);
  end;
end.

and the response is

http://tinyurl.com/2ca52me

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.

Download the full sourcecode from here

(compiled using delphi 2007)

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>';

Download the full sourcecode from here and enjoy

(compiled under delphi XE)

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

Download the source code from here

(the demo project was compiled under Delphi XE, but the TGeoTraceThread class can be used with older versions of delphi i tested with 2007 to XE)

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;