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.
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.
Support for import Eclipse Themes (Eclipse Color Theme Plugin)
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.
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.
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.
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;
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
//------------------------------------------------------------------------------
// 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.
