The Road to Delphi

Delphi – Free Pascal – Oxygene


Leave a comment

Added support for Delphi 5 and 6 in the Delphi IDE Theme Editor

Some fellows coders ask me (and request) about add support to the delphi 5 and delphi 6 IDEs. these versions was not originally supported by the  Delphi IDE Theme Editor because these IDEs gives you a 16 fixed colors palette. So this causes  limitations to manage the themes.

Check this image for the IDE editor options in Delphi 5 which shows the 16 colors available

the option to assign any color to the Highlight elements was added in the Delphi 7 version

The first thing I thought to manage the 16 palette colors was use specific themes with contains combinations of colors using these 16 colors. But quickly discarded this solution because would be necessary handle specific themes for specific versions of the delphi IDEs.  So finally I decide convert the colors themes to the 16 color palette using some algorithm to find the closest color to the palette. the algorithm chosen was the Euclidean distance where  closest color is determined by the distance between the two corresponding points in three-dimensional space.  for example to find the distance of two colors  (r1,g1,b1) and (r2,g2,b2)  the formula look like this

Now the dephi implementation of the algorithm to find the “straight-line distance” or “nearest color” using the Euclidean distance:


const
  DelphiOldColorsCount =16;
  //this is the 16 colors palette used by delphi 5 and delphi 6 IDEs (BGR format)
  DelphiOldColorsList: array[0..DelphiOldColorsCount-1] of TColor =
  (
    $000000,$000080,$008000,$008080,
    $800000,$800080,$808000,$C0C0C0,
    $808080,$0000FF,$00FF00,$00FFFF,
    $FF0000,$FF00FF,$FFFF00,$FFFFFF
  )

function GetIndexClosestColor(AColor:TColor) : Integer;
var
  SqrDist,SmallSqrDist  : Double;
  i,R1,G1,B1,R2,G2,B2   : Integer;
begin
  Result:=0;
  //set the max distance possible
  SmallSqrDist := Sqrt(SQR(255)*3);
  //get the RGB components of the original color
  R1 := GetRValue(AColor);
  G1 := GetGValue(AColor);
  B1 := GetBValue(AColor);

    for i := 0 to DelphiOldColorsCount-1 do
    begin
      //get the RGB components of the palette color
      R2 := GetRValue(DelphiOldColorsList[i]);
      G2 := GetGValue(DelphiOldColorsList[i]);
      B2 := GetBValue(DelphiOldColorsList[i]);
      //calculate the euclidean distance
      SqrDist := Sqrt(SQR(R1 - R2) + SQR(G1 - G2) + SQR(B1 - B2));
      if SqrDist < SmallSqrDist then
      begin
       Result := i;
       SmallSqrDist := SqrDist;
      end
    end
end;

Applying the above function the results are

Aqua Theme Original (Delphi 7 and Above)

Aqua Theme Modified (Delphi 5 and Delphi 6)


NightFall Theme Original (Delphi 7 and Above)

NightFall Theme Modified (Delphi 5 and Delphi 6)

I think which the final result is acceptable (remember the palette is 16 colors only) . Now you can download the updated version of the Delphi IDE Theme Editor from here.


11 Comments

Delphi IDE Theme Editor – New features

New features was added to the Delphi IDE Theme Editor

  • The GUI was improved to reflect more elements of the syntax highlighting (Active Line, Enabled break point, Disabled break point, execution point, error line), also when you click in any place in the editor the associated element is shown in the selection list.

  • New option to change the Hue/Saturation of any theme. This functionality allow you create new themes in seconds

 

  • More Themes added, now you have 50+ themes to personalize you Delphi IDE.
  • Finally an new page was created on my blog to publish the last news and features added to the Delphi IDE Theme Editor.

Download the Delphi IDE Theme Editor from here

And remember your suggestions and comments are very important to improve the application.


58 Comments

Is Your Delphi IDE Hot or Not? – Introducing the Delphi IDE Theme Editor

UPDATE : Visit the new page of the project to check the new features.

The last weekend I was working in a new project called Delphi IDE Theme Editor. this tool allow to change the Delphi (Rad studio) color settings.
the application was written using Delphi XE and the Unicode SynEdit components.

Here some features

  • Supports Delphi 7, 2005, BDS/Turbo 2006 and RAD Studio 2007, 2009, 2010, XE
  • Can import Visual Studio Themes 2003,2008,2010 (.vssettings)
  • You can revert any changes made to the IDE pressing the button “Set default theme values for selected IDE”
  • 35 themes are included, ready to use in your Delphi IDE.

Screenshot of the application

Look the dephi IDE

check this video to see how the application set a new theme to Delphi IDE

See how the tool can import a Visual Studio Theme (.vssettings) and apply this style to Delphi IDE.

some tips

  • Check the site studiostyles to get a lot of themes which you can import to the Delphi IDE.
  • If your system does not have the Consolas font installed you can download the Consolas Font Pack for Microsoft Visual Studio 2005 or 2008 from here

In the next days I will publish the full the source code and the technical details of the tool, so stay tuned.

Let me know If you have any suggestion or comments to improve the application.

Download the application from here


14 Comments

A New project – Delphi (Object Pascal) WMI class code generator

The lasts weeks I’ve been working in a new project, called Delphi WMI class code generator. let me tell you about it.

The WMI (Windows Management Instrumentation) is formed by many classes, this classes exposes properties and methods. Also each class, property and method have qualifiers which are something like attributes, these qualifiers include descriptions about the classes, method, parameters or properties, types and many more useful information.

Now to access the properties of a wmi class from object pascal code is a very easy task, as was shown in this post, but by the other side to access the methods is little more complicated, because you need to known if the method is static or dynamic. also you must deal in some cases with complicated parameters which must be variants arrays, objects or datetime (in UTC format). and finally some of these parameters can be optional. so if you are only an occasional user of the WMI you must figure out a lot of thinks before to use it.

Because that and to the experience gained when I wrote the WMI Delphi Code Creator application, I decided to go a couple of steps forward and create tool which facilitate the access to the properties and methods exposed by the WMI classes from Object Pascal code.

The result was a code generator which parse the very rich meta-data of the wmi classes and extract the properties and methods and convert into a Object pascal class.

Now Let me show a sample code generated by the tool for the Win32_Share Wmi class.

/// <summary>
/// Unit generated using the Delphi Wmi class generator tool, Copyright Rodrigo Ruz V. 2010
/// Application version 0.1.0.120
/// WMI version 7600.16385
/// Creation Date 24-12-2010 09:38:11
/// Namespace root\CIMV2 Class Win32_Share
/// MSDN info about this class http://msdn2.microsoft.com/library/default.asp?url=/library/en-us/wmisdk/wmi/Win32_Share.asp
/// </summary>

{$IFDEF FPC}
 {$MODE DELPHI} {$H+}
 {$DEFINE OLD_DELPHI}
{$ENDIF}

unit uWin32_Share;

interface

uses
 Classes,
 Activex,
 Variants,
 ComObj,
 uWmiDelphiClass;

type
{$IFDEF FPC}
 Cardinal=Longint;
 Int64=Integer;
 Word=Longint;
{$ENDIF}
{$IFNDEF FPC}
 {$IF CompilerVersion <= 15}
 {$DEFINE OLD_DELPHI}
 {$IFEND}
{$ENDIF}
 {$IFDEF UNDEF}{$REGION 'Documentation'}{$ENDIF}
 /// <summary>
 /// The Win32_Share class represents a shared resource on a Win32 system. This may be a disk drive, printer, interprocess communication, or other shareable device.
 /// Example: C:\PUBLIC.
 /// </summary>
 {$IFDEF UNDEF}{$ENDREGION}{$ENDIF}
 TWin32_Share=class(TWmiClass)
 private
 FAccessMask                         : Cardinal;
 FAllowMaximum                       : Boolean;
 FCaption                            : String;
 FDescription                        : String;
 FInstallDate                        : TDateTime;
 FMaximumAllowed                     : Cardinal;
 FName                               : String;
 FPath                               : String;
 FStatus                             : String;
 FType                               : Cardinal;
 public
 constructor Create(LoadWmiData : boolean=True); overload;
 destructor Destroy;Override;
 {$IFDEF UNDEF}{$REGION 'Documentation'}{$ENDIF}
 /// <summary>
 /// This property has been deprecated in favour of the GetAccessMask method of this
 /// class due to the expense of calling GetEffectiveRightsFromAcl. The value will
 /// be set to NULL
 /// </summary>
 {$IFDEF UNDEF}{$ENDREGION}{$ENDIF}
 property AccessMask : Cardinal read FAccessMask;
 {$IFDEF UNDEF}{$REGION 'Documentation'}{$ENDIF}
 /// <summary>
 /// The AllowMaximum property indicates whether the number of concurrent users for this resource has been limited.
 /// Values: TRUE or FALSE. A value of TRUE indicates the number of concurrent users of this resource has not been limited and the value in the MaximumAllowed property is ignored.
 /// </summary>
 {$IFDEF UNDEF}{$ENDREGION}{$ENDIF}
 property AllowMaximum : Boolean read FAllowMaximum;
 {$IFDEF UNDEF}{$REGION 'Documentation'}{$ENDIF}
 /// <summary>
 /// The Caption property is a short textual description (one-line string) of the
 /// object.
 /// </summary>
 {$IFDEF UNDEF}{$ENDREGION}{$ENDIF}
 property Caption : String read FCaption;
 {$IFDEF UNDEF}{$REGION 'Documentation'}{$ENDIF}
 /// <summary>
 /// The Description property provides a textual description of the object.
 /// </summary>
 {$IFDEF UNDEF}{$ENDREGION}{$ENDIF}
 property Description : String read FDescription;
 {$IFDEF UNDEF}{$REGION 'Documentation'}{$ENDIF}
 /// <summary>
 /// The InstallDate property is datetime value indicating when the object was
 /// installed. A lack of a value does not indicate that the object is not installed.
 /// </summary>
 {$IFDEF UNDEF}{$ENDREGION}{$ENDIF}
 property InstallDate : TDateTime read FInstallDate;
 {$IFDEF UNDEF}{$REGION 'Documentation'}{$ENDIF}
 /// <summary>
 /// The MaximumAllowed property indicates the limit on the maximum number of users allowed to use this resource concurrently. The value is only valid if the AllowMaximum member set to FALSE
 /// Example: 10.
 /// </summary>
 {$IFDEF UNDEF}{$ENDREGION}{$ENDIF}
 property MaximumAllowed : Cardinal read FMaximumAllowed;
 {$IFDEF UNDEF}{$REGION 'Documentation'}{$ENDIF}
 /// <summary>
 /// The Name property indicates the alias given to a path set up as a share on a  Win32 system.
 /// Example: public.
 /// </summary>
 {$IFDEF UNDEF}{$ENDREGION}{$ENDIF}
 property Name : String read FName;
 {$IFDEF UNDEF}{$REGION 'Documentation'}{$ENDIF}
 /// <summary>
 /// The Path property indicates the local path of the Win32 share.
 /// Example: C:\Program Files
 /// </summary>
 {$IFDEF UNDEF}{$ENDREGION}{$ENDIF}
 property Path : String read FPath;
 {$IFDEF UNDEF}{$REGION 'Documentation'}{$ENDIF}
 /// <summary>
 /// The Status property is a string indicating the current status of the object.
 /// Various operational and non-operational statuses can be defined. Operational
 /// statuses are "OK", "Degraded" and "Pred Fail". "Pred Fail" indicates that an
 /// element may be functioning properly but predicting a failure in the near
 /// future. An example is a SMART-enabled hard drive. Non-operational statuses can
 /// also be specified. These are "Error", "Starting", "Stopping" and "Service". The
 /// latter, "Service", could apply during mirror-resilvering of a disk, reload of a
 /// user permissions list, or other administrative work. Not all such work is on-
 /// line, yet the managed element is neither "OK" nor in one of the other states.
 /// </summary>
 {$IFDEF UNDEF}{$ENDREGION}{$ENDIF}
 property Status : String read FStatus;
 {$IFDEF UNDEF}{$REGION 'Documentation'}{$ENDIF}
 /// <summary>
 /// The Type property specifies the type of resource being shared. Types include
 /// disk drives, print queues, interprocess communications (IPC), and general
 /// devices.
 /// </summary>
 {$IFDEF UNDEF}{$ENDREGION}{$ENDIF}
 property {$IFDEF OLD_DELPHI}_Type{$ELSE}&Type{$ENDIF} : Cardinal read FType;
 function Create(const Access : OleVariant;const Description : String;const MaximumAllowed : Cardinal;const Name : String;const Password : String;const Path : String;const {$IFDEF OLD_DELPHI}_Type{$ELSE}&Type{$ENDIF} : Cardinal): Integer;overload;
 function SetShareInfo(const Access : OleVariant;const Description : String;const MaximumAllowed : Cardinal): Integer;
 function GetAccessMask: Integer;
 function Delete: Integer;
 procedure SetCollectionIndex(Index : Integer); override;
 end;

 {$IFDEF UNDEF}{$REGION 'Documentation'}{$ENDIF}
 /// <summary>
 /// Return the description for the value of the property TWin32_Share.Type
 /// </summary>
 {$IFDEF UNDEF}{$ENDREGION}{$ENDIF}
 function GetTypeAsString(const APropValue:Cardinal) : string;

implementation

function GetTypeAsString(const APropValue:Cardinal) : string;
begin
Result:='';
 case APropValue of
 0 : Result:='Disk Drive';
 1 : Result:='Print Queue';
 2 : Result:='Device';
 3 : Result:='IPC';
 2147483648 : Result:='Disk Drive Admin';
 2147483649 : Result:='Print Queue Admin';
 2147483650 : Result:='Device Admin';
 2147483651 : Result:='IPC Admin';
 end;
end;

{TWin32_Share}

constructor TWin32_Share.Create(LoadWmiData : boolean=True);
begin
 inherited Create(LoadWmiData,'root\CIMV2','Win32_Share');
end;

destructor TWin32_Share.Destroy;
begin
 inherited;
end;

procedure TWin32_Share.SetCollectionIndex(Index : Integer);
begin
 if (Index>=0) and (Index<=FWmiCollection.Count-1) and (FWmiCollectionIndex<>Index) then
 begin
 FWmiCollectionIndex:=Index;
 FAccessMask          := VarCardinalNull(inherited Value['AccessMask']);
 FAllowMaximum        := VarBoolNull(inherited Value['AllowMaximum']);
 FCaption             := VarStrNull(inherited Value['Caption']);
 FDescription         := VarStrNull(inherited Value['Description']);
 FInstallDate         := VarDateTimeNull(inherited Value['InstallDate']);
 FMaximumAllowed      := VarCardinalNull(inherited Value['MaximumAllowed']);
 FName                := VarStrNull(inherited Value['Name']);
 FPath                := VarStrNull(inherited Value['Path']);
 FStatus              := VarStrNull(inherited Value['Status']);
 FType                := VarCardinalNull(inherited Value['Type']);
 end;
end;

//static, OutParams=1, InParams>0
function TWin32_Share.Create(const Access : OleVariant;const Description : String;const MaximumAllowed : Cardinal;const Name : String;const Password : String;const Path : String;const {$IFDEF OLD_DELPHI}_Type{$ELSE}&Type{$ENDIF} : Cardinal): Integer;
var
 objInParams                : OleVariant;
 objOutParams               : OleVariant;
begin
 objInParams                 := GetInstanceOf.Methods_.Item('Create').InParameters.SpawnInstance_();
 objInParams.Properties_.Item('Access').Value  := Access;
 objInParams.Properties_.Item('Description').Value  := Description;
 objInParams.Properties_.Item('MaximumAllowed').Value  := MaximumAllowed;
 objInParams.Properties_.Item('Name').Value  := Name;
 objInParams.Properties_.Item('Password').Value  := Password;
 objInParams.Properties_.Item('Path').Value  := Path;
 objInParams.Properties_.Item('Type').Value  := {$IFDEF OLD_DELPHI}_Type{$ELSE}&Type{$ENDIF};
 objOutParams                := WMIService.ExecMethod(WmiClass, 'Create', objInParams, 0, GetNullValue);
 Result := VarIntegerNull(objOutParams.ReturnValue);
end;

//not static, OutParams=1, InParams>0
function TWin32_Share.SetShareInfo(const Access : OleVariant;const Description : String;const MaximumAllowed : Cardinal): Integer;
var
 ReturnValue : OleVariant;
begin
 ReturnValue := GetInstanceOf.SetShareInfo(Access,Description,MaximumAllowed);
 Result      := VarIntegerNull(ReturnValue);
end;

//not static, OutParams=1, InParams=0
function TWin32_Share.GetAccessMask: integer;
var
 ReturnValue : OleVariant;
begin
 ReturnValue := GetInstanceOf.GetAccessMask;
 Result      := VarIntegerNull(ReturnValue);
end;

//not static, OutParams=1, InParams=0
function TWin32_Share.Delete: integer;
var
 ReturnValue : OleVariant;
begin
 ReturnValue := GetInstanceOf.Delete;
 Result      := VarIntegerNull(ReturnValue);
end;
end.

as you can see the generated code is a full documented class compatible with the delphi help insight feature, available since Delphi 2005.

check this screen-shot which show the help insight for the Getowner method of the Win32_Process class.

This tool not only facilitate the access to the wmi, also give you information about every single WMI class, method and property.

here some features of the application

  • The code generated is compatible Delphi 7, 2005, BDS/Turbo 2006 and RAD Studio 2007, 2009, 2010, XE and the Free Pascal Compiler 2.2.4 (win32)
  • Create full documented classes compatible with the help insight feature, available since Delphi 2005.
    Note : the language of the description of the methods, parameters and properties depends on of the language of the windows where you generate the units.
  • Create additional helper functions to retrieve the description of the returned values for the properties and functions.
  • Support access to the WMI of the remote computers.

Now see this sample application which uses a class generated by the tool to access the BIOS information of a Remote PC.

program TestRemote;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  uWmiDelphiClass in '..\..\uWmiDelphiClass.pas', //the base class must be always included
  uWin32_BIOS in '..\..\root_CIMV2\uWin32_BIOS.pas'; //the class with the BIOs information

var
  RemoteBiosInfo : TWin32_BIOS;
  i              : integer;
begin
   try
     RemoteBiosInfo:=TWin32_BIOS.Create(False); //Create a instance of the TWin32_BIOS, the false value indicate which not load the Values when calls the constructor.
     try

       RemoteBiosInfo.WmiServer:='192.168.217.128'; //the remote pc name or IP
       RemoteBiosInfo.WmiUser  :='Administrator'; //the user used to establish the connection
       RemoteBiosInfo.WmiPass  :='password'; //the password
       RemoteBiosInfo.LoadWmiData; //now load the the data of the class

       if RemoteBiosInfo.WmiConnected then  //check if the connection was established
       begin
         Writeln('Serial Number       '+RemoteBiosInfo.SerialNumber);
         Writeln('BuildNumber         '+RemoteBiosInfo.BuildNumber);
         if RemoteBiosInfo.BIOSVersion.Count>0 then
         Writeln('Version             '+RemoteBiosInfo.BIOSVersion[0]);
         Writeln('Identification Code '+RemoteBiosInfo.IdentificationCode);
         Writeln('Manufacturer        '+RemoteBiosInfo.Manufacturer);
         Writeln('SoftwareElementID   '+RemoteBiosInfo.SoftwareElementID);
         Writeln('Release Date        '+DateToStr(RemoteBiosInfo.ReleaseDate));
         Writeln('Install Date        '+DateToStr(RemoteBiosInfo.InstallDate));
         Writeln('Target S.O          '+GetTargetOperatingSystemAsString(RemoteBiosInfo.TargetOperatingSystem));
         Writeln('Soft. element state '+GetSoftwareElementStateAsString(RemoteBiosInfo.SoftwareElementState));

         Writeln('');
         Writeln('Bios Characteristics');
         Writeln('--------------------');
         for i:=Low(RemoteBiosInfo.BiosCharacteristics)  to High(RemoteBiosInfo.BiosCharacteristics) do
          Writeln(GetBiosCharacteristicsAsString(RemoteBiosInfo.BiosCharacteristics[i]));
       end
       else
       Writeln('No connected');
     finally
      RemoteBiosInfo.Free;
     end;
   except
    on E:Exception do
     Writeln(E.Classname, ': ', E.Message);
   end;

 Readln;
end.

You can found more information about the internals, the full source code, demos and samples of this tool in the google code project page.

See you, and happy new year.


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)


19 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.