The Road to Delphi

Delphi – Free Pascal – Oxygene


3 Comments

Detecting the language from a text using the Google translate API v1

UPDATE

The Google Translate API has been officially deprecated  an alternative  is the Microsoft Translator V2, check this article for more details.

 

In this past post we use the Google translate API v2 to translate from an language to another. today will show how use the current version of this API (v1) which include a nice functionality to detect the language from a given text.

This API can be accessed via JavaScript  in a web page or using a HTTP request. in the next sample i will use the second option.

Before to continue you must aware of this warning of Google.

Note: The Google Translate API must be used for user-generated translations. Automated or batched queries of any kind are strictly prohibited.

Here you can find the Terms of Service of this API.

The next code is for educational purposes only.

To detect the language from a text you must make  a request to his URI

https://ajax.googleapis.com/ajax/services/language/detect?v=1.0&q=Hello+World

As you can see the only required parameter is the encoded text to detect.

the  JSON response to this request will be something like this

{ "responseData" : { "confidence" : 0.11489271400000001,
      "isReliable" : false,
      "language" : "en"
    },
  "responseDetails" : null,
  "responseStatus" : 200
}

the responseStatus contain the result of the operation, the 200 indicate which the language from text was successfully detected.

So now we need to define a few types, functions and constants to make the work more easy.

type
  //the supported languages
  TGoogleLanguages=
  (Autodetect,Afrikaans,Albanian,Arabic,Basque,Belarusian,Bulgarian,Catalan,Chinese,Chinese_Traditional,
  Croatian,Czech,Danish,Dutch,English,Estonian,Filipino,Finnish,French,Galician,German,Greek,
  Haitian_Creole,Hebrew,Hindi,Hungarian,Icelandic,Indonesian,Irish,Italian,Japanese,Latvian,
  Lithuanian,Macedonian,Malay,Maltese,Norwegian,Persian,Polish,Portuguese,Romanian,Russian,
  Serbian,Slovak,Slovenian,Spanish,Swahili,Swedish,Thai,Turkish,Ukrainian,Vietnamese,Welsh,Yiddish,Unknow);

  //the string representation for the enumerated types
  const
  GoogleLanguagesStr : array[TGoogleLanguages] of string =
  ('Autodetect','Afrikaans','Albanian','Arabic','Basque','Belarusian','Bulgarian','Catalan','Chinese','Chinese_Traditional',
  'Croatian','Czech','Danish','Dutch','English','Estonian','Filipino','Finnish','French','Galician','German','Greek',
  'Haitian_Creole','Hebrew','Hindi','Hungarian','Icelandic','Indonesian','Irish','Italian','Japanese','Latvian',
  'Lithuanian','Macedonian','Malay','Maltese','Norwegian','Persian','Polish','Portuguese','Romanian','Russian',
  'Serbian','Slovak','Slovenian','Spanish','Swahili','Swedish','Thai','Turkish','Ukrainian','Vietnamese','Welsh','Yiddish','Unknow');

  //The languages code to be used in HTTP request
  GoogleLanguagesArr : array[TGoogleLanguages] of string =
  ( 'Autodetect','af','sq','ar','eu','be','bg','ca','zh-CN','zh-TW','hr','cs','da','nl','en','et','tl','fi','fr','gl',
    'de','el','ht','iw','hi','hu','is','id','ga','it','ja','lv','lt','mk','ms','mt','no','fa','pl','pt',
    'ro','ru','sr','sk','sl','es','sw','sv','th','tr','uk','vi','cy','yi','Unknow');

  //URI to translate a text using the V1 from the API
  GoogleTranslateUrl='https://ajax.googleapis.com/ajax/services/language/translate?v=1.0&q=%s&langpair=%s';
  //URI to detect the language from a text
  GoogleLngDetectUrl='https://ajax.googleapis.com/ajax/services/language/detect?v=1.0&q=%s';

//return a stream containing the HTTP response InternetOpen
procedure WinInet_HttpGet(const Url: string;Stream:TStream);overload;
const
BuffSize = 1024*1024;
var
  hInter   : HINTERNET;
  UrlHandle: HINTERNET;
  BytesRead: DWORD;
  Buffer   : Pointer;
begin
  hInter := InternetOpen('', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if Assigned(hInter) then
  begin
    Stream.Seek(0,0);
    GetMem(Buffer,BuffSize);
    try
        UrlHandle := InternetOpenUrl(hInter, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);
        if Assigned(UrlHandle) then
        begin
          repeat
            InternetReadFile(UrlHandle, Buffer, BuffSize, BytesRead);
            if BytesRead>0 then
             Stream.WriteBuffer(Buffer^,BytesRead);
          until BytesRead = 0;
          InternetCloseHandle(UrlHandle);
        end;
    finally
      FreeMem(Buffer);
    end;
    InternetCloseHandle(hInter);
  end
end;

//return a string containing the HTTP response.
function WinInet_HttpGet(const Url: string): string;overload;
Var
  StringStream : TStringStream;
begin
  Result:='';
    StringStream:=TStringStream.Create('',TEncoding.UTF8);
    try
        WinInet_HttpGet(Url,StringStream);
        if StringStream.Size>0 then
        begin
          StringStream.Seek(0,0);
          Result:=StringStream.ReadString(StringStream.Size);
        end;
    finally
      StringStream.Free;
    end;
end;

And now to process the response using the DBXJSON unit

function DetectLanguage_DBXJSON(const Text:string):TGoogleLanguages;
var
  EncodedRequest: string;
  json          : TJSONObject;
  jPair         : TJSONPair;
  jValue        : TJSONValue;
  Response      : string;
  Lng           : TGoogleLanguages;
  LngStr        : string;
begin
  Result:=Unknow;
  EncodedRequest:=Format(GoogleLngDetectUrl,[HTTPEncode(Text)]);
  Response:=WinInet_HttpGet(EncodedRequest);

  if Response<>'' then
  begin
      json    := TJSONObject.ParseJSONValue(TEncoding.ASCII.GetBytes(Response),0) as TJSONObject;
    try
      jPair   := json.Get(2);//get the responseStatus
      if jPair.JsonValue.ToString<>'200' then  //200 is all ok
        Result := Unknow
      else
      begin
        jPair  := json.Get(0);
        jValue := TJSONObject(jPair.JsonValue).Get(0).JsonValue;
        LngStr := jValue.Value;
        for lng:=Low(TGoogleLanguages) to High(TGoogleLanguages)  do
        if GoogleLanguagesArr[Lng]=LngStr then
        begin
         Result:=lng;
         exit;
        end;
      end;
    finally
       json.Free;
    end;
  end;
end;

Another alternative using the JSON superobject library

function DetectLanguage_JSONsuperobject(const Text:string):TGoogleLanguages;
var
  EncodedRequest: string;
  Response      : string;
  Lng           : TGoogleLanguages;
  LngStr        : string;
begin
  Result:=Unknow;
  EncodedRequest:=Format(GoogleLngDetectUrl,[HTTPEncode(Text)]);
  Response:=WinInet_HttpGet(EncodedRequest);
  if Response<>'' then
  begin
    if SO(Response)['responseStatus'].AsInteger<>200 then   //if responseStatus<>200 then exist a error in the response
      Result:=Unknow
    else
    begin
      LngStr:=SO(Response)['responseData.language'].AsString;
      for lng:=Low(TGoogleLanguages) to High(TGoogleLanguages)  do
      if GoogleLanguagesArr[Lng]=LngStr then
      begin
       Result:=lng;
       exit;
      end;
    end;
  end;
end;

and finally a option without JSON

function DetectLanguage_JSONLess(const Text:string):TGoogleLanguages;
const
  TagErr='{"responseData": null,';
  TagIOk='{"responseData": {"language":"';
  TagFOk='","isReliable":';
var
  EncodedRequest: string;
  Response      : string;
  Lng           : TGoogleLanguages;
  LngStr        : string;
begin
  Result:=Unknow;
  EncodedRequest:=Format(GoogleLngDetectUrl,[HTTPEncode(Text)]);
  Response:=WinInet_HttpGet(EncodedRequest);

  if Response<>'' then
  begin
    if StartsStr(TagErr,(Response)) then  //Response  Error
    begin
      Result:=Unknow
    end
    else
    begin  //Response Ok
      LngStr:=StringReplace(Response,TagIOk,'',[rfReplaceAll]);
      LngStr:=Copy(LngStr,1,Pos(TagFOk,LngStr)-1);
        for lng:=Low(TGoogleLanguages) to High(TGoogleLanguages)  do
        if GoogleLanguagesArr[Lng]=LngStr then
        begin
         Result:=lng;
         exit;
        end;
    end;
  end;
end;

To finish here i leave the full source code from a console application which show all the alternatives to decode the JSON response and as extra include the routine to translate a text using the Google translate API v1.

program GoogleAPITranslateV1;

{$APPTYPE CONSOLE}
{$DEFINE USE_SUPER_OBJECT}
{$DEFINE USE_DBXJSON}
{$DEFINE USE_JSONLess}

uses
  Windows
  ,Classes
  ,WinInet
  ,Activex
  ,HTTPApp
  ,SysUtils
  {$IFDEF USE_JSONLess}
  ,StrUtils
  {$ENDIF}
  {$IFDEF USE_SUPER_OBJECT}
  ,superobject
  {$ENDIF}
  {$IFDEF USE_DBXJSON}
  ,DBXJSON
  {$ENDIF}
  ;

type
  TGoogleLanguages=
  (Autodetect,Afrikaans,Albanian,Arabic,Basque,Belarusian,Bulgarian,Catalan,Chinese,Chinese_Traditional,
  Croatian,Czech,Danish,Dutch,English,Estonian,Filipino,Finnish,French,Galician,German,Greek,
  Haitian_Creole,Hebrew,Hindi,Hungarian,Icelandic,Indonesian,Irish,Italian,Japanese,Latvian,
  Lithuanian,Macedonian,Malay,Maltese,Norwegian,Persian,Polish,Portuguese,Romanian,Russian,
  Serbian,Slovak,Slovenian,Spanish,Swahili,Swedish,Thai,Turkish,Ukrainian,Vietnamese,Welsh,Yiddish,Unknow);

  const
  GoogleLanguagesStr : array[TGoogleLanguages] of string =
  ('Autodetect','Afrikaans','Albanian','Arabic','Basque','Belarusian','Bulgarian','Catalan','Chinese','Chinese_Traditional',
  'Croatian','Czech','Danish','Dutch','English','Estonian','Filipino','Finnish','French','Galician','German','Greek',
  'Haitian_Creole','Hebrew','Hindi','Hungarian','Icelandic','Indonesian','Irish','Italian','Japanese','Latvian',
  'Lithuanian','Macedonian','Malay','Maltese','Norwegian','Persian','Polish','Portuguese','Romanian','Russian',
  'Serbian','Slovak','Slovenian','Spanish','Swahili','Swedish','Thai','Turkish','Ukrainian','Vietnamese','Welsh','Yiddish','Unknow');

  GoogleLanguagesArr : array[TGoogleLanguages] of string =
  ( 'Autodetect','af','sq','ar','eu','be','bg','ca','zh-CN','zh-TW','hr','cs','da','nl','en','et','tl','fi','fr','gl',
    'de','el','ht','iw','hi','hu','is','id','ga','it','ja','lv','lt','mk','ms','mt','no','fa','pl','pt',
    'ro','ru','sr','sk','sl','es','sw','sv','th','tr','uk','vi','cy','yi','Unknow');

  GoogleTranslateUrl='https://ajax.googleapis.com/ajax/services/language/translate?v=1.0&q=%s&langpair=%s';
  //http://code.google.com/apis/language/translate/v1/using_rest_translate.html
  GoogleLngDetectUrl='https://ajax.googleapis.com/ajax/services/language/detect?v=1.0&q=%s';

procedure WinInet_HttpGet(const Url: string;Stream:TStream);overload;
const
BuffSize = 1024*1024;
var
  hInter   : HINTERNET;
  UrlHandle: HINTERNET;
  BytesRead: DWORD;
  Buffer   : Pointer;
begin
  hInter := InternetOpen('Mozilla/3.0', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if Assigned(hInter) then
  begin
    Stream.Seek(0,0);
    GetMem(Buffer,BuffSize);
    try
        UrlHandle := InternetOpenUrl(hInter, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);
        if Assigned(UrlHandle) then
        begin
          repeat
            InternetReadFile(UrlHandle, Buffer, BuffSize, BytesRead);
            if BytesRead>0 then
             Stream.WriteBuffer(Buffer^,BytesRead);
          until BytesRead = 0;
          InternetCloseHandle(UrlHandle);
        end;
    finally
      FreeMem(Buffer);
    end;
    InternetCloseHandle(hInter);
  end
end;

function WinInet_HttpGet(const Url: string): string;overload;
Var
  StringStream : TStringStream;
begin
  Result:='';
    StringStream:=TStringStream.Create('',TEncoding.UTF8);
    try
        WinInet_HttpGet(Url,StringStream);
        if StringStream.Size>0 then
        begin
          StringStream.Seek(0,0);
          Result:=StringStream.ReadString(StringStream.Size);
        end;
    finally
      StringStream.Free;
    end;
end;

{$IFDEF USE_SUPER_OBJECT}
function DetectLanguage_JSONsuperobject(const Text:string):TGoogleLanguages;
var
  EncodedRequest: string;
  Response      : string;
  Lng           : TGoogleLanguages;
  LngStr        : string;
begin
  Result:=Unknow;
  EncodedRequest:=Format(GoogleLngDetectUrl,[HTTPEncode(Text)]);
  Response:=WinInet_HttpGet(EncodedRequest);
  if Response<>'' then
  begin
    if SO(Response)['responseStatus'].AsInteger<>200 then   //if responseStatus<>200 then exist a error in the response
      Result:=Unknow
    else
    begin
      LngStr:=SO(Response)['responseData.language'].AsString;
      for lng:=Low(TGoogleLanguages) to High(TGoogleLanguages)  do
      if GoogleLanguagesArr[Lng]=LngStr then
      begin
       Result:=lng;
       exit;
      end;
    end;
  end;
end;

function Translate_JSONsuperobject(const Text:string;Source,Dest:TGoogleLanguages):string;
var
  EncodedRequest: string;
  Response      : string;
begin
  Result:='';
  if Source=Autodetect then
   EncodedRequest:=Format(GoogleTranslateUrl,[HTTPEncode(Text),'%7C'+GoogleLanguagesArr[Dest]])
  else
   EncodedRequest:=Format(GoogleTranslateUrl,[HTTPEncode(Text),GoogleLanguagesArr[Source]+'%7C'+GoogleLanguagesArr[Dest]]);

  Response:=WinInet_HttpGet(EncodedRequest);
  if Response<>'' then
  begin
    if SO(Response)['responseData'].AsObject=nil then   //if the first element is null then ocurrs an error
      Result:=Format('Error Code %d %s',[SO(Response)['responseStatus'].AsInteger,SO(Response)['responseDetails'].AsString])
    else
      Result:=SO(Response)['responseData.translatedText'].AsString;
  end;
end;
{$ENDIF}

{$IFDEF USE_DBXJSON}
function DetectLanguage_DBXJSON(const Text:string):TGoogleLanguages;
var
  EncodedRequest: string;
  json          : TJSONObject;
  jPair         : TJSONPair;
  jValue        : TJSONValue;
  Response      : string;
  Lng           : TGoogleLanguages;
  LngStr        : string;
begin
  Result:=Unknow;
  EncodedRequest:=Format(GoogleLngDetectUrl,[HTTPEncode(Text)]);
  Response:=WinInet_HttpGet(EncodedRequest);
  if Response<>'' then
  begin
      json    := TJSONObject.ParseJSONValue(TEncoding.ASCII.GetBytes(Response),0) as TJSONObject;
    try
      jPair   := json.Get(2);//get the responseStatus
      if jPair.JsonValue.ToString<>'200' then  //200 is all ok
        Result := Unknow
      else
      begin
        jPair  := json.Get(0);
        jValue := TJSONObject(jPair.JsonValue).Get(0).JsonValue;
        LngStr := jValue.Value;
        for lng:=Low(TGoogleLanguages) to High(TGoogleLanguages)  do
        if GoogleLanguagesArr[Lng]=LngStr then
        begin
         Result:=lng;
         exit;
        end;
      end;
    finally
       json.Free;
    end;
  end;
end;

function Translate_DBXJSON(const Text:string;Source,Dest:TGoogleLanguages):string;
var
  EncodedRequest: string;
  json          : TJSONObject;
  jPair         : TJSONPair;
  jValue        : TJSONValue;
  Response      : string;
begin
  Result:='';
  if Source=Autodetect then
   EncodedRequest:=Format(GoogleTranslateUrl,[HTTPEncode(Text),'%7C'+GoogleLanguagesArr[Dest]])
  else
   EncodedRequest:=Format(GoogleTranslateUrl,[HTTPEncode(Text),GoogleLanguagesArr[Source]+'%7C'+GoogleLanguagesArr[Dest]]);

  Response:=WinInet_HttpGet(EncodedRequest);
  if Response<>'' then
  begin
      json    := TJSONObject.ParseJSONValue(TEncoding.ASCII.GetBytes(Response),0) as TJSONObject;
    try
      jPair   := json.Get(2);//get the responseStatus
      if jPair.JsonValue.ToString<>'200' then  //200 is all ok
        //{"responseData": null, "responseDetails": "invalid translation language pair", "responseStatus": 400}
        Result := Format('Error Code %s message %s',[json.Get(2).JsonValue.ToString,json.Get(1).JsonValue.ToString])
      else
      begin
        jPair  := json.Get(0);
        jValue := TJSONObject(jPair.JsonValue).Get(0).JsonValue;
        Result := jValue.ToString;
      end;
    finally
       json.Free;
    end;
      Result:=HTMLDecode(Result);
  end;
end;
{$ENDIF}

{$IFDEF USE_JSONLess}
function DetectLanguage_JSONLess(const Text:string):TGoogleLanguages;
const
  TagErr='{"responseData": null,';
  TagIOk='{"responseData": {"language":"';
  TagFOk='","isReliable":';
var
  EncodedRequest: string;
  Response      : string;
  Lng           : TGoogleLanguages;
  LngStr        : string;
begin
  Result:=Unknow;
  EncodedRequest:=Format(GoogleLngDetectUrl,[HTTPEncode(Text)]);
  Response:=WinInet_HttpGet(EncodedRequest); //{"responseData": {"language":"en","isReliable":false,"confidence":0.114892714},"responseDetails": null, "responseStatus": 200}

  if Response<>'' then
  begin
    if StartsStr(TagErr,(Response)) then  //Response  Error
    begin
      Result:=Unknow
    end
    else
    begin  //Response Ok
      LngStr:=StringReplace(Response,TagIOk,'',[rfReplaceAll]);
      LngStr:=Copy(LngStr,1,Pos(TagFOk,LngStr)-1);
        for lng:=Low(TGoogleLanguages) to High(TGoogleLanguages)  do
        if GoogleLanguagesArr[Lng]=LngStr then
        begin
         Result:=lng;
         exit;
        end;
    end;
  end;
end;

function Translate_JSONLess(const Text:string;Source,Dest:TGoogleLanguages):string;
const
  TagErr='{"responseData": null,';

  TagIOk='{"responseData": {"translatedText":"';
  TagAut=',"detectedSourceLanguage":"';

  TagFOk='"}, "responseDetails":';
var
  EncodedRequest: string;
  Response      : string;
begin
  Result:='';
  if Source=Autodetect then
   EncodedRequest:=Format(GoogleTranslateUrl,[HTTPEncode(Text),'%7C'+GoogleLanguagesArr[Dest]])
  else
   EncodedRequest:=Format(GoogleTranslateUrl,[HTTPEncode(Text),GoogleLanguagesArr[Source]+'%7C'+GoogleLanguagesArr[Dest]]);

  Response:=WinInet_HttpGet(EncodedRequest);
  if Response<>'' then
  begin
    if StartsStr(TagErr,(Response)) then  //Response  Error
    begin
      Result:='Error'
    end
    else
    begin  //Response Ok
      if Source=Autodetect then
      begin
        Result:=StringReplace(Response,TagIOk,'',[rfReplaceAll]);
        Result:=Copy(Result,1,Pos(TagAut,Result)-2);
      end
      else
      begin
        Result:=StringReplace(Response,TagIOk,'',[rfReplaceAll]);
        Result:=Copy(Result,1,Pos(TagFOk,Result)-1);
      end;
    end;

    Result:=HTMLDecode(Result);
  end;
end;
{$ENDIF}

Const
 Text   ='Hello World';
 TextEn ='Hello World';
 TextEs ='Hola Mundo';
Var
 TranslatedText : string;
begin
  try
    CoInitialize(nil);
    try
       {$IFDEF USE_JSONLess}
       Writeln('Without JSON (very ugly)');
       Writeln('');
       TranslatedText:=Translate_JSONLess(Text,Autodetect,Spanish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONLess(Text,English,Chinese_Traditional);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONLess(Text,English,German);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONLess(Text,English,Danish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONLess(Text,English,Portuguese);
       Writeln(TranslatedText);
       Writeln('');

       Writeln('Detecting language Without JSON');
       Writeln('');
       Writeln(Format('language detected for "%s"  : %s',[TextEn,GoogleLanguagesStr[DetectLanguage_JSONLess(TextEn)]]));
       Writeln(Format('language detected for "%s"  : %s',[TextEs,GoogleLanguagesStr[DetectLanguage_JSONLess(TextEs)]]));
       {$ENDIF}

       {$IFDEF USE_SUPER_OBJECT}
       Writeln('Using the superobject library');
       Writeln('');
       TranslatedText:=Translate_JSONsuperobject(Text,Autodetect,Spanish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONsuperobject(Text,English,Chinese_Traditional);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONsuperobject(Text,English,German);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONsuperobject(Text,English,Danish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONsuperobject(Text,English,Portuguese);
       Writeln(TranslatedText);
       Writeln('');

       Writeln('Detecting language using the superobject library');
       Writeln('');
       Writeln(Format('language detected for "%s"  : %s',[TextEn,GoogleLanguagesStr[DetectLanguage_JSONsuperobject(TextEn)]]));
       Writeln(Format('language detected for "%s"  : %s',[TextEs,GoogleLanguagesStr[DetectLanguage_JSONsuperobject(TextEs)]]));
       {$ENDIF}

       {$IFDEF USE_DBXJSON}
       Writeln('Using the DBXJSON unit');
       Writeln('');
       TranslatedText:=Translate_DBXJSON(Text,Autodetect,Spanish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_DBXJSON(Text,English,Chinese_Traditional);
       Writeln(TranslatedText);
       TranslatedText:=Translate_DBXJSON(Text,English,German);
       Writeln(TranslatedText);
       TranslatedText:=Translate_DBXJSON(Text,English,Danish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_DBXJSON(Text,English,Portuguese);
       Writeln(TranslatedText);
       Writeln('');

       Writeln('Detecting language using the DBXJSON unit');
       Writeln('');
       Writeln(Format('language detected for "%s"  : %s',[TextEn,GoogleLanguagesStr[DetectLanguage_DBXJSON(TextEn)]]));
       Writeln(Format('language detected for "%s"  : %s',[TextEs,GoogleLanguagesStr[DetectLanguage_DBXJSON(TextEs)]]));
       {$ENDIF}

    finally
     CoUninitialize;
    end;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.


25 Comments

Generating Qr Codes with Delphi

 The QR Codes are a  special kind of images that used to represent two-dimensional barcodes. They are also known as hardlinks or physical world hyperlinks.

The QR Codes can store up to 4,296 alphanumeric characters of arbitrary text. The  QR codes can be read by an optical device with the appropriate software. Such devices range from dedicated QR code readers to mobile phones.

On this post I will show you how using the Google Chart Tools / Image Charts (aka Chart API) you can easily generate QR codes.

Using this API is very  straightforward, all you need to do is to generate a QR Code is make a Get request to this URI

http://chart.apis.google.com/chart?chs=200x200&cht=qr&chld=M&chl=Go+Delphi+Go

And how response you will get a png image (you can change the output format to gif adding the chof parameter to the URI  like so : chof=gif).

On the Google Chart Documentation you can find more info about the parameters to generate a QR Code.

Note : If you want encode more of 2000 chars do you need make a post request (this up to you).

Finally this a sample Delphi source to generate a QR Code.


uses
 PngImage,
 HTTPApp,
 WinInet;

type
TQrImage_ErrCorrLevel=(L,M,Q,H);

const
UrlGoogleQrCode='http://chart.apis.google.com/chart?chs=%dx%d&cht=qr&chld=%s&chl=%s';
QrImgCorrStr   : array [TQrImage_ErrCorrLevel] of string=('L','M','Q','H');

procedure WinInet_HttpGet(const Url: string;Stream:TStream);
const
BuffSize = 1024*1024;
var
  hInter   : HINTERNET;
  UrlHandle: HINTERNET;
  BytesRead: DWORD;
  Buffer   : Pointer;
begin
  hInter := InternetOpen('', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if Assigned(hInter) then
  begin
    Stream.Seek(0,0);
    GetMem(Buffer,BuffSize);
    try
        UrlHandle := InternetOpenUrl(hInter, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);
        if Assigned(UrlHandle) then
        begin
          repeat
            InternetReadFile(UrlHandle, Buffer, BuffSize, BytesRead);
            if BytesRead>0 then
             Stream.WriteBuffer(Buffer^,BytesRead);
          until BytesRead = 0;
          InternetCloseHandle(UrlHandle);
        end;
    finally
      FreeMem(Buffer);
    end;
    InternetCloseHandle(hInter);
  end
end;

//this function return a Stream (PngImage inside) with a Qr code.
procedure GetQrCode(Width,Height:Word;Correction_Level:TQrImage_ErrCorrLevel;const Data:string;StreamImage : TMemoryStream);
Var
 EncodedURL  : string;
begin
  EncodedURL:=Format(UrlGoogleQrCode,[Width,Height,QrImgCorrStr[Correction_Level],HTTPEncode(Data)]);
  WinInet_HttpGet(EncodedURL,StreamImage);
end;

Check the source code of the application on Github


19 Comments

Using the Google Translate API V2 (Labs) from Delphi

UPDATE

The Google Translate API has been officially deprecated  an alternative  is the Microsoft Translator V2, check this article for more details.

 

In this post i will show you how work with the Google Translate API V2 (Labs),  this API lets you automatically translates text from one language to another.

Disclaimer

  • This version of the Google Translate API is in Labs, and its features might change unexpectedly until it graduates.
  • The Google Translate API requires the use of an API key, which you can get from the Google APIs console
  • Before to use this API check the Google Translate API Terms of Use.

To use the Google Translate API you must send a HTTP GET request to its URI.

The URI for a request has the following format:

https://www.googleapis.com/language/translate/v2?parameters

Example to making a request to translate the Hello World text from English (en) to Spanish (es) the URI must be constructed in this way

https://www.googleapis.com/language/translate/v2?key=INSERT-YOUR-KEY&source=en&target=es&q=Hello%20world

The response in JSON format will be

{"data":{"translations":[{"translatedText":"Hola Mundo"}]}}

To activate the auto-detection of the source language you must avoid the use of the source keyword

https://www.googleapis.com/language/translate/v2?key=INSERT-YOUR-KEY&target=es&q=Hello%20world

and the JSON response in this case will be

{"data":{"translations":[{"translatedText":"Hola a todos","detectedSourceLanguage":"en"}]}

if you pass incorrect parameters the response will look like this

{"error":{"errors":[{"domain":"global","reason":"invalid","message":"Invalid Value"}],"code":400,"message":"Invalid Value"}}

some conversions between languages are not allowed by the API, in thi case you will get a response of this type

{"error":{"errors":[{"domain":"global","reason":"badRequest","message":"Bad language pair: en|zh-TW"}],"code":400,"message":"Bad language pair: en|zh-TW"}}

Now I will show 3 ways to process the data

Using the JSON – SuperObject , this library is very well written and is very easy to use, also is compatible with olders versions of Delphi and Freepascal (win32/64 linux32/64).

function Translate_JSONsuperobject(const Text:string;Source,Dest:TGoogleLanguages):string;
var
  XMLHTTPRequest: IXMLHTTPRequest;
  EncodedRequest: string;
  Response      : string;
begin
  Result:='';
  if Source=Autodetect then //build the URI
    EncodedRequest:=Format(GoogleTranslateUrlAuto,[GoogleLanguageApiKey,GoogleLanguagesArr[Dest],HTTPEncode(Text)])
  else
    EncodedRequest:=Format(GoogleTranslateUrl,[GoogleLanguageApiKey,HTTPEncode(Text),GoogleLanguagesArr[Source],GoogleLanguagesArr[Dest]]);

  XMLHTTPRequest := CoXMLHTTP.Create;
  XMLHTTPRequest.open('GET', EncodedRequest, False, EmptyParam, EmptyParam); //Make the request
  XMLHTTPRequest.send('');
  Response:=XMLHTTPRequest.responseText;
  if Response<>'' then
  begin
    if SO(Response)['error']=nil then //all ok
     Result := SO(Response)['data.translations[0].translatedText'].AsString
    else //exist an error response
     Result := Format('Error Code %d message %s',[SO(Response)['error.code'].AsInteger,SO(Response)['error.message'].AsString]);
     Result:=HTMLDecode(Result);
  end;

end;

Using the DBXJSON unit included since Delphi 2010

function Translate_DBXJSON(const Text:string;Source,Dest:TGoogleLanguages):string;
var
  XMLHTTPRequest: IXMLHTTPRequest;
  EncodedRequest: string;
  json          : TJSONObject;
  jPair         : TJSONPair;
  jValue        : TJSONValue;
  Response      : string;
begin
  Result:='';
  if Source=Autodetect then //buil the URI
    EncodedRequest:=Format(GoogleTranslateUrlAuto,[GoogleLanguageApiKey,GoogleLanguagesArr[Dest],HTTPEncode(Text)])
  else
    EncodedRequest:=Format(GoogleTranslateUrl,[GoogleLanguageApiKey,HTTPEncode(Text),GoogleLanguagesArr[Source],GoogleLanguagesArr[Dest]]);

  XMLHTTPRequest := CoXMLHTTP.Create;
  XMLHTTPRequest.open('GET', EncodedRequest, False, EmptyParam, EmptyParam); //make the request
  XMLHTTPRequest.send('');
  Response:=XMLHTTPRequest.responseText;

  if Response<>'' then
  begin
      json    := TJSONObject.ParseJSONValue(TEncoding.ASCII.GetBytes(Response),0) as TJSONObject; //create a TJSONObject instance
    try
      jPair   := json.Get(0);
      if jPair.JsonString.value='error' then //if error in response
        Result := Format('Error Code %s message %s',[TJSONObject(jPair.JsonValue).Get(1).JsonValue.Value,TJSONObject(jPair.JsonValue).Get(2).JsonValue.Value])
      else //all ok, show the response,
      begin
        jValue := TJSONArray(TJSONObject(jPair.JsonValue).Get(0).JsonValue).Get(0);
        Result := TJSONObject(jValue).Get(0).JsonValue.Value;
      end;
    finally
       json.Free;
    end;

      Result:=HTMLDecode(Result);
  end;
end;

and finally without using JSON, a very ugly way, but works.

function Translate_JSONLess(const Text:string;Source,Dest:TGoogleLanguages):string;
const
  TagIOk='{"data":{"translations":[{"translatedText":"';
  TagFOk='"}]}}';
  TagErr='{"error":{"errors":[{';
  TagAut=',"detectedSourceLanguage":"';
var
  XMLHTTPRequest: IXMLHTTPRequest;
  EncodedRequest: string;
  Response      : string;
begin
  Result:='';

  if Source=Autodetect then //build the URI
    EncodedRequest:=Format(GoogleTranslateUrlAuto,[GoogleLanguageApiKey,GoogleLanguagesArr[Dest],HTTPEncode(Text)])
  else
    EncodedRequest:=Format(GoogleTranslateUrl,[GoogleLanguageApiKey,HTTPEncode(Text),GoogleLanguagesArr[Source],GoogleLanguagesArr[Dest]]);

  XMLHTTPRequest := CoXMLHTTP.Create;
  XMLHTTPRequest.open('GET', EncodedRequest, False, EmptyParam, EmptyParam); //make the request
  XMLHTTPRequest.send('');
  Response:=XMLHTTPRequest.responseText;
  if Response<>'' then
  begin
    if StartsStr(TagErr,(Response)) then  //Response  Error
    begin
      Result:='Error'
    end
    else
    begin  //Response Ok
      if Source=Autodetect then
      begin
        Result:=StringReplace(Response,TagIOk,'',[rfReplaceAll]); //remove tags
        Result:=Copy(Result,1,Pos(TagAut,Result)-2);//remove tags
      end
      else
      begin
        Result:=StringReplace(Response,TagIOk,'',[rfReplaceAll]);//remove tags
        Result:=StringReplace(Result,TagFOk,'',[rfReplaceAll]);//remove tags
      end;
    end;

    Result:=HTMLDecode(Result);
  end;
end;

Check the full source showing the 3 ways to access the Google Translate API, listed in this entry.

program GoogleAPITranslate;
//Author  : Rodrigo Ruz V. 2010-12-03  03;30 A.M

{$APPTYPE CONSOLE}
{$DEFINE USE_SUPER_OBJECT}
{$DEFINE USE_DBXJSON}
{$DEFINE USE_JSONLess}

uses
   msxml
  ,Activex
  ,HTTPApp
  ,Variants
  ,SysUtils
  {$IFDEF USE_JSONLess}
  ,StrUtils
  {$ENDIF}
  {$IFDEF USE_SUPER_OBJECT}
  ,superobject
  {$ENDIF}
  {$IFDEF USE_DBXJSON}
  ,DBXJSON
  {$ENDIF}
  ;

  type
  TGoogleLanguages=
  (Autodetect,Afrikaans,Albanian,Arabic,Basque,Belarusian,Bulgarian,Catalan,Chinese,Chinese_Traditional,
  Croatian,Czech,Danish,Dutch,English,Estonian,Filipino,Finnish,French,Galician,German,Greek,
  Haitian_Creole,Hebrew,Hindi,Hungarian,Icelandic,Indonesian,Irish,Italian,Japanese,Latvian,
  Lithuanian,Macedonian,Malay,Maltese,Norwegian,Persian,Polish,Portuguese,Romanian,Russian,
  Serbian,Slovak,Slovenian,Spanish,Swahili,Swedish,Thai,Turkish,Ukrainian,Vietnamese,Welsh,Yiddish);

  const
  GoogleLanguagesArr : array[TGoogleLanguages] of string =
  ( 'Autodetect','af','sq','ar','eu','be','bg','ca','zh-CN','zh-TW','hr','cs','da','nl','en','et','tl','fi','fr','gl',
    'de','el','ht','iw','hi','hu','is','id','ga','it','ja','lv','lt','mk','ms','mt','no','fa','pl','pt',
    'ro','ru','sr','sk','sl','es','sw','sv','th','tr','uk','vi','cy','yi');

  //¡¡¡¡¡¡Please be nice and create your own Google Api Key ¡¡¡¡¡¡¡
  GoogleLanguageApiKey   ='AIzaSyDb18pd1IfkYyupC2XUIANcRoB3f9J2DJg';
  GoogleTranslateUrl     ='https://www.googleapis.com/language/translate/v2?key=%s&q=%s&source=%s&target=%s';
  GoogleTranslateUrlAuto ='https://www.googleapis.com/language/translate/v2?key=%s&target=%s&q=%s';

{$IFDEF USE_DBXJSON}
function Translate_DBXJSON(const Text:string;Source,Dest:TGoogleLanguages):string;
var
  XMLHTTPRequest: IXMLHTTPRequest;
  EncodedRequest: string;
  json          : TJSONObject;
  jPair         : TJSONPair;
  jValue        : TJSONValue;
  Response      : string;
begin
  Result:='';
  if Source=Autodetect then
    EncodedRequest:=Format(GoogleTranslateUrlAuto,[GoogleLanguageApiKey,GoogleLanguagesArr[Dest],HTTPEncode(Text)])
  else
    EncodedRequest:=Format(GoogleTranslateUrl,[GoogleLanguageApiKey,HTTPEncode(Text),GoogleLanguagesArr[Source],GoogleLanguagesArr[Dest]]);

  XMLHTTPRequest := CoXMLHTTP.Create;
  XMLHTTPRequest.open('GET', EncodedRequest, False, EmptyParam, EmptyParam);
  XMLHTTPRequest.send('');
  Response:=XMLHTTPRequest.responseText;

  if Response<>'' then
  begin
      json    := TJSONObject.ParseJSONValue(TEncoding.ASCII.GetBytes(Response),0) as TJSONObject;
    try
      jPair   := json.Get(0);
      if jPair.JsonString.value='error' then
        //{"error":{"errors":[{"domain":"global","reason":"invalid","message":"Invalid Value"}],"code":400,"message":"Invalid Value"}}
        Result := Format('Error Code %s message %s',[TJSONObject(jPair.JsonValue).Get(1).JsonValue.Value,TJSONObject(jPair.JsonValue).Get(2).JsonValue.Value])
      else
      begin
        //{"data":{"translations":[{"translatedText":"Hola a todos","detectedSourceLanguage":"en"}]}}
        jValue := TJSONArray(TJSONObject(jPair.JsonValue).Get(0).JsonValue).Get(0);
        Result := TJSONObject(jValue).Get(0).JsonValue.Value;
      end;
    finally
       json.Free;
    end;

      Result:=HTMLDecode(Result);
  end;
end;
{$ENDIF}

{$IFDEF USE_SUPER_OBJECT}
function Translate_JSONsuperobject(const Text:string;Source,Dest:TGoogleLanguages):string;
var
  XMLHTTPRequest: IXMLHTTPRequest;
  EncodedRequest: string;
  Response      : string;
begin
  Result:='';
  if Source=Autodetect then
    EncodedRequest:=Format(GoogleTranslateUrlAuto,[GoogleLanguageApiKey,GoogleLanguagesArr[Dest],HTTPEncode(Text)])
  else
    EncodedRequest:=Format(GoogleTranslateUrl,[GoogleLanguageApiKey,HTTPEncode(Text),GoogleLanguagesArr[Source],GoogleLanguagesArr[Dest]]);

  XMLHTTPRequest := CoXMLHTTP.Create;
  XMLHTTPRequest.open('GET', EncodedRequest, False, EmptyParam, EmptyParam);
  XMLHTTPRequest.send('');
  Response:=XMLHTTPRequest.responseText;
  if Response<>'' then
  begin
  //{"data":{"translations":[{"translatedText":"Hola a todos","detectedSourceLanguage":"en"}]}}
    if SO(Response)['error']=nil then
     Result := SO(Response)['data.translations[0].translatedText'].AsString
    else
     //{"error":{"errors":[{"domain":"global","reason":"invalid","message":"Invalid Value"}],"code":400,"message":"Invalid Value"}}
     //{"error":{"errors":[{"domain":"global","reason":"badRequest","message":"Bad language pair: en|zh-TW"}],"code":400,"message":"Bad language pair: en|zh-TW"}}
     Result := Format('Error Code %d message %s',[SO(Response)['error.code'].AsInteger,SO(Response)['error.message'].AsString]);
     Result:=HTMLDecode(Result);
  end;

end;
{$ENDIF}

{$IFDEF USE_JSONLess}
function Translate_JSONLess(const Text:string;Source,Dest:TGoogleLanguages):string;
const
  TagIOk='{"data":{"translations":[{"translatedText":"';
  TagFOk='"}]}}';
  TagErr='{"error":{"errors":[{';
  TagAut=',"detectedSourceLanguage":"';
var
  XMLHTTPRequest: IXMLHTTPRequest;
  EncodedRequest: string;
  Response      : string;
begin
  Result:='';

  if Source=Autodetect then
    EncodedRequest:=Format(GoogleTranslateUrlAuto,[GoogleLanguageApiKey,GoogleLanguagesArr[Dest],HTTPEncode(Text)])
  else
    EncodedRequest:=Format(GoogleTranslateUrl,[GoogleLanguageApiKey,HTTPEncode(Text),GoogleLanguagesArr[Source],GoogleLanguagesArr[Dest]]);

  XMLHTTPRequest := CoXMLHTTP.Create;
  XMLHTTPRequest.open('GET', EncodedRequest, False, EmptyParam, EmptyParam);
  XMLHTTPRequest.send('');
  Response:=XMLHTTPRequest.responseText;
  if Response<>'' then
  begin
    if StartsStr(TagErr,(Response)) then  //Response  Error
    begin
      Result:='Error'
    end
    else
    begin  //Response Ok
      if Source=Autodetect then
      begin
        Result:=StringReplace(Response,TagIOk,'',[rfReplaceAll]);
        Result:=Copy(Result,1,Pos(TagAut,Result)-2);
      end
      else
      begin
        Result:=StringReplace(Response,TagIOk,'',[rfReplaceAll]);
        Result:=StringReplace(Result,TagFOk,'',[rfReplaceAll]);
      end;
    end;

    Result:=HTMLDecode(Result);
  end;
end;
{$ENDIF}

Const
 Text ='"Hello  World"';
Var
 TranslatedText : string;
begin
  try
    CoInitialize(nil);
    try
       {$IFDEF USE_JSONLess}
       Writeln('Without JSON (very ugly)');
       Writeln('');
       TranslatedText:=Translate_JSONLess(Text,Autodetect,Spanish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONLess(Text,English,Chinese_Traditional);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONLess(Text,English,German);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONLess(Text,English,Danish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONLess(Text,English,Portuguese);
       Writeln(TranslatedText);
       Writeln('');
       {$ENDIF}

       {$IFDEF USE_SUPER_OBJECT}
       Writeln('Using the superobject library');
       Writeln('');
       TranslatedText:=Translate_JSONsuperobject(Text,Autodetect,Spanish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONsuperobject(Text,English,Chinese_Traditional);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONsuperobject(Text,English,German);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONsuperobject(Text,English,Danish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_JSONsuperobject(Text,English,Portuguese);
       Writeln(TranslatedText);
       Writeln('');
       {$ENDIF}

       {$IFDEF USE_DBXJSON}
       Writeln('Using the DBXJSON unit');
       Writeln('');
       TranslatedText:=Translate_DBXJSON(Text,Autodetect,Spanish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_DBXJSON(Text,English,Chinese_Traditional);
       Writeln(TranslatedText);
       TranslatedText:=Translate_DBXJSON(Text,English,German);
       Writeln(TranslatedText);
       TranslatedText:=Translate_DBXJSON(Text,English,Danish);
       Writeln(TranslatedText);
       TranslatedText:=Translate_DBXJSON(Text,English,Portuguese);
       Writeln(TranslatedText);
       Writeln('');
       {$ENDIF}

    finally
     CoUninitialize;
    end;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  Readln;
end.
Check this link  <a href=”http://code.google.com/apis/language/translate/terms.html&#8221; rel=”nofollow”>Google Translate API Terms of Use</a>.


12 Comments

Generating a “unique” hardware ID using Delphi and the WMI

The general idea to generate a Hardware ID (machine fingerprint) is collect data from the CPU, HDD, BIOS, NIC and another hardware components which have serial numbers and unique characteristics. you can use this ID to generate licenses based in this fingerprint which must be “unique” by machine.

for this simple sample i picked this set of WMI classes Win32_Processor (Get CPU info), Win32_BaseBoard (retrieve info about the motherboard), Win32_BIOS (Get BIOS Data) and Win32_OperatingSystem (Get Windows information). Of course you can choose other WMI classes, and combinations that you want.

Check the full source code of the hardware ID generator.

(Tested in Delphi 2007 and Delphi XE)

program WMIHardwareID;

{$APPTYPE CONSOLE}
{$DEFINE Use_Jwscl} //necessary to obtain a hash of the data using md2, md4, md5 or sha1

uses
  {$IFDEF Use_Jwscl}
  JwsclTypes,
  JwsclCryptProvider,
  {$ENDIF}
  Classes,
  SysUtils,
  ActiveX,
  ComObj,
  Variants;

type
   TMotherBoardInfo   = (Mb_SerialNumber,Mb_Manufacturer,Mb_Product,Mb_Model);
   TMotherBoardInfoSet= set of TMotherBoardInfo;
   TProcessorInfo     = (Pr_Description,Pr_Manufacturer,Pr_Name,Pr_ProcessorId,Pr_UniqueId);
   TProcessorInfoSet  = set of TProcessorInfo;
   TBIOSInfo          = (Bs_BIOSVersion,Bs_BuildNumber,Bs_Description,Bs_Manufacturer,Bs_Name,Bs_SerialNumber,Bs_Version);
   TBIOSInfoSet       = set of TBIOSInfo;
   TOSInfo            = (Os_BuildNumber,Os_BuildType,Os_Manufacturer,Os_Name,Os_SerialNumber,Os_Version);
   TOSInfoSet         = set of TOSInfo;

const //properties names to get the data
   MotherBoardInfoArr: array[TMotherBoardInfo] of AnsiString =
                        ('SerialNumber','Manufacturer','Product','Model');

   OsInfoArr         : array[TOSInfo] of AnsiString =
                        ('BuildNumber','BuildType','Manufacturer','Name','SerialNumber','Version');

   BiosInfoArr       : array[TBIOSInfo] of AnsiString =
                        ('BIOSVersion','BuildNumber','Description','Manufacturer','Name','SerialNumber','Version');

   ProcessorInfoArr  : array[TProcessorInfo] of AnsiString =
                        ('Description','Manufacturer','Name','ProcessorId','UniqueId');

type
   THardwareId  = class
   private
    FOSInfo         : TOSInfoSet;
    FBIOSInfo       : TBIOSInfoSet;
    FProcessorInfo  : TProcessorInfoSet;
    FMotherBoardInfo: TMotherBoardInfoSet;
    FBuffer         : AnsiString;
    function GetHardwareIdHex: AnsiString;
  {$IFDEF Use_Jwscl}
    function GetHashString(Algorithm: TJwHashAlgorithm; Buffer : Pointer;Size:Integer) : AnsiString;
    function GetHardwareIdMd5: AnsiString;
    function GetHardwareIdMd2: AnsiString;
    function GetHardwareIdMd4: AnsiString;
    function GetHardwareIdSHA: AnsiString;
  {$ENDIF}
   public
     //Set the properties to  be used in the generation of the hardware id
    property  MotherBoardInfo : TMotherBoardInfoSet read FMotherBoardInfo write FMotherBoardInfo;
    property  ProcessorInfo : TProcessorInfoSet read FProcessorInfo write FProcessorInfo;
    property  BIOSInfo: TBIOSInfoSet read FBIOSInfo write FBIOSInfo;
    property  OSInfo  : TOSInfoSet read FOSInfo write FOSInfo;
    property  Buffer : AnsiString read FBuffer; //return the content of the data collected in the system
    property  HardwareIdHex : AnsiString read GetHardwareIdHex; //get a hexadecimal represntation of the data collected
  {$IFDEF Use_Jwscl}
    property  HardwareIdMd2  : AnsiString read GetHardwareIdMd2; //get a Md2 hash of the data collected
    property  HardwareIdMd4  : AnsiString read GetHardwareIdMd4; //get a Md4 hash of the data collected
    property  HardwareIdMd5  : AnsiString read GetHardwareIdMd5; //get a Md5 hash of the data collected
    property  HardwareIdSHA  : AnsiString read GetHardwareIdSHA; //get a SHA1 hash of the data collected
  {$ENDIF}
    procedure GenerateHardwareId; //calculate the hardware id
    constructor  Create(Generate:Boolean=True); overload;
    Destructor  Destroy; override;
   end;

function VarArrayToStr(const vArray: variant): AnsiString;

  function _VarToStr(const V: variant): AnsiString;
  var
  Vt: integer;
  begin
   Vt := VarType(V);
      case Vt of
        varSmallint,
        varInteger  : Result := AnsiString(IntToStr(integer(V)));
        varSingle,
        varDouble,
        varCurrency : Result := AnsiString(FloatToStr(Double(V)));
        varDate     : Result := AnsiString(VarToStr(V));
        varOleStr   : Result := AnsiString(WideString(V));
        varBoolean  : Result := AnsiString(VarToStr(V));
        varVariant  : Result := AnsiString(VarToStr(Variant(V)));
        varByte     : Result := AnsiChar(byte(V));
        varString   : Result := AnsiString(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):AnsiString; //avoid problems with null strings
begin
  Result:='';
  if not VarIsNull(V) then
  begin
    if VarIsArray(V) then
       Result:=VarArrayToStr(V)
    else
    Result:=AnsiString(VarToStr(V));
  end;
end;

{ THardwareId }

constructor THardwareId.Create(Generate:Boolean=True);
begin
   inherited Create;
   CoInitialize(nil);
   FBuffer          :='';
   //Set the propeties to be used in the hardware id generation
   FMotherBoardInfo :=[Mb_SerialNumber,Mb_Manufacturer,Mb_Product,Mb_Model];
   FOSInfo          :=[Os_BuildNumber,Os_BuildType,Os_Manufacturer,Os_Name,Os_SerialNumber,Os_Version];
   FBIOSInfo        :=[Bs_BIOSVersion,Bs_BuildNumber,Bs_Description,Bs_Manufacturer,Bs_Name,Bs_SerialNumber,Bs_Version];
   FProcessorInfo   :=[];//including the processor info is expensive [Pr_Description,Pr_Manufacturer,Pr_Name,Pr_ProcessorId,Pr_UniqueId];
   if Generate then
    GenerateHardwareId;
end;

destructor THardwareId.Destroy;
begin
  CoUninitialize;
  inherited;
end;

//Main function which collect the system data.
procedure THardwareId.GenerateHardwareId;
var
  objSWbemLocator : OLEVariant;
  objWMIService   : OLEVariant;
  objWbemObjectSet: OLEVariant;
  oWmiObject      : OLEVariant;
  oEnum           : IEnumvariant;
  iValue          : LongWord;
  SDummy          : AnsiString;
  Mb              : TMotherBoardInfo;
  Os              : TOSInfo;
  Bs              : TBIOSInfo;
  Pr              : TProcessorInfo;
begin;
  objSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  objWMIService   := objSWbemLocator.ConnectServer('localhost','root\cimv2', '','');

  if FMotherBoardInfo<>[] then //MotherBoard info
  begin
    objWbemObjectSet:= objWMIService.ExecQuery('SELECT * FROM Win32_BaseBoard','WQL',0);
    oEnum           := IUnknown(objWbemObjectSet._NewEnum) as IEnumVariant;
    while oEnum.Next(1, oWmiObject, iValue) = 0 do
    begin
      for Mb := Low(TMotherBoardInfo) to High(TMotherBoardInfo) do
       if Mb in FMotherBoardInfo then
       begin
          SDummy:=VarStrNull(oWmiObject.Properties_.Item(MotherBoardInfoArr[Mb]).Value);
          FBuffer:=FBuffer+SDummy;
       end;
       oWmiObject:=Unassigned;
    end;
  end;

  if FOSInfo<>[] then//Windows info
  begin
    objWbemObjectSet:= objWMIService.ExecQuery('SELECT * FROM Win32_OperatingSystem','WQL',0);
    oEnum           := IUnknown(objWbemObjectSet._NewEnum) as IEnumVariant;
    while oEnum.Next(1, oWmiObject, iValue) = 0 do
    begin
      for Os := Low(TOSInfo) to High(TOSInfo) do
       if Os in FOSInfo then
       begin
          SDummy:=VarStrNull(oWmiObject.Properties_.Item(OsInfoArr[Os]).Value);
          FBuffer:=FBuffer+SDummy;
       end;
       oWmiObject:=Unassigned;
    end;
  end;

  if FBIOSInfo<>[] then//BIOS info
  begin
    objWbemObjectSet:= objWMIService.ExecQuery('SELECT * FROM Win32_BIOS','WQL',0);
    oEnum           := IUnknown(objWbemObjectSet._NewEnum) as IEnumVariant;
    while oEnum.Next(1, oWmiObject, iValue) = 0 do
    begin
      for Bs := Low(TBIOSInfo) to High(TBIOSInfo) do
       if Bs in FBIOSInfo then
       begin
          SDummy:=VarStrNull(oWmiObject.Properties_.Item(BiosInfoArr[Bs]).Value);
          FBuffer:=FBuffer+SDummy;
       end;
       oWmiObject:=Unassigned;
    end;
  end;

  if FProcessorInfo<>[] then//CPU info
  begin
    objWbemObjectSet:= objWMIService.ExecQuery('SELECT * FROM Win32_Processor','WQL',0);
    oEnum           := IUnknown(objWbemObjectSet._NewEnum) as IEnumVariant;
    while oEnum.Next(1, oWmiObject, iValue) = 0 do
    begin
      for Pr := Low(TProcessorInfo) to High(TProcessorInfo) do
       if Pr in FProcessorInfo then
       begin
          SDummy:=VarStrNull(oWmiObject.Properties_.Item(ProcessorInfoArr[Pr]).Value);
          FBuffer:=FBuffer+SDummy;
       end;
       oWmiObject:=Unassigned;
    end;
  end;

end;

function THardwareId.GetHardwareIdHex: AnsiString;
begin
    SetLength(Result,Length(FBuffer)*2);
    BinToHex(PAnsiChar(FBuffer),PAnsiChar(Result),Length(FBuffer));
end;

{$IFDEF Use_Jwscl}
function THardwareId.GetHashString(Algorithm: TJwHashAlgorithm; Buffer : Pointer;Size:Integer) : AnsiString;
var
  Hash: TJwHash;
  HashSize: Cardinal;
  HashData: Pointer;
begin
  Hash := TJwHash.Create(Algorithm);
  try
    Hash.HashData(Buffer,Size);
    HashData := Hash.RetrieveHash(HashSize);
    try
        SetLength(Result,HashSize*2);
        BinToHex(PAnsiChar(HashData),PAnsiChar(Result),HashSize);
    finally
      TJwHash.FreeBuffer(HashData);
    end;
  finally
    Hash.Free;
  end;
end;

function THardwareId.GetHardwareIdMd2: AnsiString;
begin
   Result:=GetHashString(haMD2,@FBuffer[1],Length(FBuffer));
end;

function THardwareId.GetHardwareIdMd4: AnsiString;
begin
   Result:=GetHashString(haMD4,@FBuffer[1],Length(FBuffer));
end;

function THardwareId.GetHardwareIdMd5: AnsiString;
begin
   Result:=GetHashString(haMD5,@FBuffer[1],Length(FBuffer));
end;

function THardwareId.GetHardwareIdSHA: AnsiString;
begin
   Result:=GetHashString(haSHA,@FBuffer[1],Length(FBuffer));
end;

{$ENDIF}

//testing the THardwareId object
var
  HWID : THardwareId;
  dt   : TDateTime;
begin
 try
    HWID:=THardwareId.Create(False);
    try
       dt := Now;
       HWID.GenerateHardwareId;
       dt := now - dt;
       Writeln(Format('Hardware Id Generated in %s',[FormatDateTime('hh:mm:nn.zzz',dt)]));
       Writeln(Format('%s %s',['Buffer ',HWID.Buffer]));
       Writeln('');
       Writeln(Format('%s %s',['Hex  ',HWID.HardwareIdHex]));
      {$IFDEF Use_Jwscl}
       Writeln(Format('%s %s',['Md2  ',HWID.HardwareIdMd2]));
       Writeln(Format('%s %s',['Md4  ',HWID.HardwareIdMd4]));
       Writeln(Format('%s %s',['Md5  ',HWID.HardwareIdMd5]));
       Writeln(Format('%s %s',['SHA1 ',HWID.HardwareIdSHA]));
      {$ENDIF}
      Readln;
    finally
     HWID.Free;
    end;
 except
    on E:Exception do
    begin
        Writeln(E.Classname, ':', E.Message);
        Readln;
    end;
  end;
end.


13 Comments

Accesing the WMI from Object Pascal Code (Delphi, Oxygene, FreePascal)

Due to many developers don’t know how access the WMI from Pascal code, I decided to write this entry to show a simple set of samples using Delphi Win32, Delphi.Net, Oxygene and Free-pascal.

Delphi .Net

Delphi Prism

Delphi win32 importing the Microsoft WMIScripting Library.

Delphi win32 Late-binding.

Lazarus Late-binding

UPDATE

To access the WMI using COM  you must check this article

Accesing the WMI from Delphi and FPC via COM (without late binding or WbemScripting_TLB)

All the code samples uses the Win32_BaseBoard wmi class and are console applications just for simplicity.

The code showed in this entry can be optimized a lot for experienced developers, these simple  piece of code only pretend give a basic idea which how connect to the  WMi service and retieve data using a WQL query.

This is the Managed Object Format (MOF) representation of this class.

class Win32_BaseBoard : CIM_Card
{
  string   Caption;
  string   ConfigOptions[];
  string   CreationClassName;
  real32   Depth;
  string   Description;
  real32   Height;
  boolean  HostingBoard;
  boolean  HotSwappable;
  datetime InstallDate;
  string   Manufacturer;
  string   Model;
  string   Name;
  string   OtherIdentifyingInfo;
  string   PartNumber;
  boolean  PoweredOn;
  string   Product;
  boolean  Removable;
  boolean  Replaceable;
  string   RequirementsDescription;
  boolean  RequiresDaughterBoard;
  string   SerialNumber;
  string   SKU;
  string   SlotLayout;
  boolean  SpecialRequirements;
  string   Status;
  string   Tag;
  string   Version;
  real32   Weight;
  real32   Width;
};

Using Delphi Win32 and importing the Microsoft WMIScripting Library

This must be the most used method for accessing the WMI from Delphi Win32, basically consist in import the Microsoft WMIScripting Library and then delphi will create a wrapper containing all the types, const and enumerations to access the WMI, the main objects(interfaces) are ISWbemServices (which create a connection with WMI Windows Service) , ISWbemObjectSet (Execute a WQL Query) and ISWbemPropertySet

Check the picture to see the Microsoft Wmi Scripting library organization.

The basics steps are

1) import the Microsoft WMIScripting Library

2) Establish a connection with the WMI service in a local o remote computer. using the TSWbemLocator.ConnectServer function.

    function ConnectServer(const strServer: WideString; const strNamespace: WideString;
                           const strUser: WideString; const strPassword: WideString;
                           const strLocale: WideString; const strAuthority: WideString;
                           iSecurityFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemServices;

 

SWbemServices := CoSWbemLocator.Create.ConnectServer('.', 'root\cimv2','', '', '', '', 0, nil);

3) Execute your WQL Query using the ISWbemServices.ExecQuery function which returns a instance to the ISWbemObjectSet object.

this is the declaration of the ISWbemServices.ExecQuery

    function ExecQuery(const strQuery: WideString; const strQueryLanguage: WideString;
                       iFlags: Integer; const objWbemNamedValueSet: IDispatch): ISWbemObjectSet; safecall;

and this is a sample of calling this function

SWbemObjectSet  := SWbemServices.ExecQuery('SELECT * FROM Win32_BaseBoard','WQL', 0, nil);

4) the next step is iterate over the returned data, to do this we can use the ISWbemObjectSet._NewEnum property wich return an enumerator to the collection returned by the SWbemObjectSet

so using a IEnumVariant (which is part of the ActiveX unit) variable we can obtain the enumerator to the collection in this way.

Enum := (SWbemObjectSet._NewEnum) as IEnumVariant;

5) finally we need access the properties of the current collection, using the SWbemObject.Properties_.Item function

    while (Enum.Next(1, TempObj, Value) = S_OK) do
    begin
       SWbemObject     := IUnknown(tempObj) as ISWBemObject;
       SWbemPropertySet:= SWbemObject.Properties_;
       SWbemPropertySet.Item('SerialNumber', 0).Get_Value;//Get the value of the SerialNumber property
    end;

Advantages of importing the Microsoft WMIScripting Library

1) Full access through the IDE (code-completion) to the types, enumerations and constants of the WMIScripting Library.
2) easy to debug syntax errors which would have been missed had you used late binding.

Drawbacks

1) Depending of the Windows version which you uses, you can get different results when you import the WMIScripting Library, check this link.

2) The final exe size is incremented when you import this library.

Check the full sample source code to get a idea how use this method.

program WmiDelphiWin32_Tlb;

{$APPTYPE CONSOLE}

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

 function VarArrayToStr(const vArray: variant): string;

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

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

    Result:=Result+']';
end;

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

Procedure GetWin32_BaseBoardInfo;
var
  SWbemServices   : ISWbemServices;
  SWbemObjectSet  : ISWbemObjectSet;
  Item            : Variant;
  Enum            : IEnumVariant;
  TempObj         : OleVariant;
  Value           : Cardinal;
  SWbemObject     : ISWbemObject;
  SWbemPropertySet: ISWbemPropertySet;
begin
  SWbemServices := CoSWbemLocator.Create.ConnectServer('.', 'root\cimv2','', '', '', '', 0, nil);
  SWbemObjectSet  := SWbemServices.ExecQuery('SELECT * FROM Win32_BaseBoard','WQL', 0, nil);
  Enum := (SWbemObjectSet._NewEnum) as IEnumVariant;

    while (Enum.Next(1, TempObj, Value) = S_OK) do
    begin
       SWbemObject     := IUnknown(tempObj) as ISWBemObject;
       SWbemPropertySet:= SWbemObject.Properties_;

        Writeln(Format('Caption                   %s',[VarStrNull(SWbemPropertySet.Item('Caption', 0).Get_Value)]));// String
        Writeln(Format('ConfigOptions             %s',[VarStrNull(SWbemPropertySet.Item('ConfigOptions', 0).Get_Value)]));// String
        Writeln(Format('CreationClassName         %s',[VarStrNull(SWbemPropertySet.Item('CreationClassName', 0).Get_Value)]));// String
        Writeln(Format('Depth                     %s',[VarStrNull(SWbemPropertySet.Item('Depth', 0).Get_Value)]));// Real32
        Writeln(Format('Description               %s',[VarStrNull(SWbemPropertySet.Item('Description', 0).Get_Value)]));// String
        Writeln(Format('Height                    %s',[VarStrNull(SWbemPropertySet.Item('Height', 0).Get_Value)]));// Real32
        Writeln(Format('HostingBoard              %s',[VarStrNull(SWbemPropertySet.Item('HostingBoard', 0).Get_Value)]));// Boolean
        Writeln(Format('HotSwappable              %s',[VarStrNull(SWbemPropertySet.Item('HotSwappable', 0).Get_Value)]));// Boolean
        Writeln(Format('InstallDate               %s',[VarStrNull(SWbemPropertySet.Item('InstallDate', 0).Get_Value)]));// Datetime
        Writeln(Format('Manufacturer              %s',[VarStrNull(SWbemPropertySet.Item('Manufacturer', 0).Get_Value)]));// String
        Writeln(Format('Model                     %s',[VarStrNull(SWbemPropertySet.Item('Model', 0).Get_Value)]));// String
        Writeln(Format('Name                      %s',[VarStrNull(SWbemPropertySet.Item('Name', 0).Get_Value)]));// String
        Writeln(Format('OtherIdentifyingInfo      %s',[VarStrNull(SWbemPropertySet.Item('OtherIdentifyingInfo', 0).Get_Value)]));// String
        Writeln(Format('PartNumber                %s',[VarStrNull(SWbemPropertySet.Item('PartNumber', 0).Get_Value)]));// String
        Writeln(Format('PoweredOn                 %s',[VarStrNull(SWbemPropertySet.Item('PoweredOn', 0).Get_Value)]));// Boolean
        Writeln(Format('Product                   %s',[VarStrNull(SWbemPropertySet.Item('Product', 0).Get_Value)]));// String
        Writeln(Format('Removable                 %s',[VarStrNull(SWbemPropertySet.Item('Removable', 0).Get_Value)]));// Boolean
        Writeln(Format('Replaceable               %s',[VarStrNull(SWbemPropertySet.Item('Replaceable', 0).Get_Value)]));// Boolean
        Writeln(Format('RequirementsDescription   %s',[VarStrNull(SWbemPropertySet.Item('RequirementsDescription', 0).Get_Value)]));// String
        Writeln(Format('RequiresDaughterBoard     %s',[VarStrNull(SWbemPropertySet.Item('RequiresDaughterBoard', 0).Get_Value)]));// Boolean
        Writeln(Format('SerialNumber              %s',[VarStrNull(SWbemPropertySet.Item('SerialNumber', 0).Get_Value)]));// String
        Writeln(Format('SKU                       %s',[VarStrNull(SWbemPropertySet.Item('SKU', 0).Get_Value)]));// String
        Writeln(Format('SlotLayout                %s',[VarStrNull(SWbemPropertySet.Item('SlotLayout', 0).Get_Value)]));// String
        Writeln(Format('SpecialRequirements       %s',[VarStrNull(SWbemPropertySet.Item('SpecialRequirements', 0).Get_Value)]));// Boolean
        Writeln(Format('Status                    %s',[VarStrNull(SWbemPropertySet.Item('Status', 0).Get_Value)]));// String
        Writeln(Format('Tag                       %s',[VarStrNull(SWbemPropertySet.Item('Tag', 0).Get_Value)]));// String
        Writeln(Format('Version                   %s',[VarStrNull(SWbemPropertySet.Item('Version', 0).Get_Value)]));// String
        Writeln(Format('Weight                    %s',[VarStrNull(SWbemPropertySet.Item('Weight', 0).Get_Value)]));// Real32
        Writeln(Format('Width                     %s',[VarStrNull(SWbemPropertySet.Item('Width', 0).Get_Value)]));// Real32
        Writeln('');
        TempObj:=Unassigned;
    end;

end;

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

Using Delphi and Late-Binding

Using the CreateOleObject function

You can access the WMI using the CreateOleObject function from delphi passing the WbemScripting.SWbemLocator class name

  var
     FSWbemLocator : OLEVariant;
  begin
    FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
    //
  end;

And then to run a WQL sentence

const
  WbemUser            ='';
  WbemPassword        ='';
  WbemComputer        ='localhost';
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator : OLEVariant;
  FWMIService   : OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject   : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  //create an instance to the WMI Scripting SWbemLocator
  FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  //connect to the server
  FWMIService   := FSWbemLocator.ConnectServer(WbemComputer, 'root\CIMV2', WbemUser, WbemPassword);
  //execute the WQL sentence
  FWbemObjectSet:= FWMIService.ExecQuery('SELECT * FROM Win32_BaseBoard','WQL',wbemFlagForwardOnly);
  //get the enumerator
  oEnum         := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
  //traverse the data
  while oEnum.Next(1, FWbemObject, iValue) = 0 do
  begin
    Writeln(Format('Caption    %s',[FWbemObject.Caption]));// String
    Writeln('');
    FWbemObject:=Unassigned;
  end;
end;

Using a Moniker

Another way to access the WMI is using a Moniker, to do this we need to use the IBindCtx and IMoniker interfaces.

Check this sample to create a wmi instance using these interfaces.

  function GetWMIObject(const objectName: String): IDispatch;
  var
    chEaten: Integer;
    BindCtx: IBindCtx;//for access to a bind context
    Moniker: IMoniker;//Enables you to use a moniker object
  begin
    OleCheck(CreateBindCtx(0, bindCtx));
    OleCheck(MkParseDisplayName(BindCtx, StringToOleStr(objectName), chEaten, Moniker));//Converts a string into a moniker that identifies the object named by the string
    OleCheck(Moniker.BindToObject(BindCtx, nil, IDispatch, Result));//Binds to the specified object
  end;

//and call in this way
GetWMIObject('winmgmts:\\localhost\root\CIMV2');

Now we can run the query an get the results

See the snippet, is very similar to the used when we import the WbemScripting_TLB unit. but the main difference is which all the variables are declarated as Variants (OLEVariant) because we don’t have available the types, enumeratios and constants of the WbemScripting_TLB unit.

var
  objWMIService : OLEVariant;
  colItems      : OLEVariant;
  colItem       : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  objWMIService := GetWMIObject('winmgmts:\\localhost\root\CIMV2');
  colItems      := objWMIService.ExecQuery('SELECT * FROM Win32_BaseBoard','WQL',0);
  oEnum         := IUnknown(colItems._NewEnum) as IEnumVariant;

3) finally to access a particular property we can get the value directly using his name.

 while oEnum.Next(1, colItem, iValue) = 0 do
 begin
     Writeln('Serial Number : '+colItem.SerialNumber);
     colItem:=Unassigned; //avoid memory leaks caused by the oEnum.Next function
 end;

Advantages of Late Binding

1. Is a very flexible solution to access the WMI, and the code to manage the wmi objects is very close to vbscript, which is good because there are thousands of examples of vbscript on the Internet to access the WMI Data.

2. Another very important advantage is that code which uses late binding is more certain to be version-independent, because when you create a WMIObject using winmgmts you are not referencing any particular version of the WMI.

3. The final exe executable is small because you don’t import any wrapper.

Drawbacks

1. You don’t have access to the wmi types, constants and enumerations from the ide, because the code is interpreted in run-time.

2. Hard to debug syntax errors,because the compiler don’t know about the WMI types
so you can write something like this (which is wrong) and the code will be compiled anyway.

 colItems.Properties_('Prop').Qualifiers_;

the right version must be.

 colItems.Properties_.Item('Prop').Qualifiers_;

Check the code using Late Binding to access the WMI from delphi (Valid for versions 5 to XE)

program WmiDelphiWin32_LateBinding;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  ActiveX,
  ComObj,
  Variants;//introduced in delphi 6, if you use a older version of delphi you just remove this

function VarArrayToStr(const vArray: variant): string;

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

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

    Result:=Result+']';
end;

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

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

//The Win32_BaseBoard class represents a base board (also known as a motherboard
//or system board).

procedure  GetWin32_BaseBoardInfo;
var
  objWMIService : OLEVariant;
  colItems      : OLEVariant;
  colItem       : OLEVariant;
  oEnum         : IEnumvariant;
  iValue        : LongWord;
begin;
  objWMIService := GetWMIObject('winmgmts:\\localhost\root\CIMV2');
  colItems      := objWMIService.ExecQuery('SELECT * FROM Win32_BaseBoard','WQL',0);
  oEnum         := IUnknown(colItems._NewEnum) as IEnumVariant;
  while oEnum.Next(1, colItem, iValue) = 0 do
  begin
    Writeln(Format('Caption                  %s',[VarStrNull(colItem.Caption)]));// String
    Writeln(Format('ConfigOptions            %s',[VarStrNull(colItem.ConfigOptions)]));// String
    Writeln(Format('CreationClassName        %s',[VarStrNull(colItem.CreationClassName)]));// String
    Writeln(Format('Depth                    %s',[VarStrNull(colItem.Depth)]));// Real32
    Writeln(Format('Description              %s',[VarStrNull(colItem.Description)]));// String
    Writeln(Format('Height                   %s',[VarStrNull(colItem.Height)]));// Real32
    Writeln(Format('HostingBoard             %s',[VarStrNull(colItem.HostingBoard)]));// Boolean
    Writeln(Format('HotSwappable             %s',[VarStrNull(colItem.HotSwappable)]));// Boolean
    Writeln(Format('InstallDate              %s',[VarStrNull(colItem.InstallDate)]));// Datetime
    Writeln(Format('Manufacturer             %s',[VarStrNull(colItem.Manufacturer)]));// String
    Writeln(Format('Model                    %s',[VarStrNull(colItem.Model)]));// String
    Writeln(Format('Name                     %s',[VarStrNull(colItem.Name)]));// String
    Writeln(Format('OtherIdentifyingInfo     %s',[VarStrNull(colItem.OtherIdentifyingInfo)]));// String
    Writeln(Format('PartNumber               %s',[VarStrNull(colItem.PartNumber)]));// String
    Writeln(Format('PoweredOn                %s',[VarStrNull(colItem.PoweredOn)]));// Boolean
    Writeln(Format('Product                  %s',[VarStrNull(colItem.Product)]));// String
    Writeln(Format('Removable                %s',[VarStrNull(colItem.Removable)]));// Boolean
    Writeln(Format('Replaceable              %s',[VarStrNull(colItem.Replaceable)]));// Boolean
    Writeln(Format('RequirementsDescription  %s',[VarStrNull(colItem.RequirementsDescription)]));// String
    Writeln(Format('RequiresDaughterBoard    %s',[VarStrNull(colItem.RequiresDaughterBoard)]));// Boolean
    Writeln(Format('SerialNumber             %s',[VarStrNull(colItem.SerialNumber)]));// String
    Writeln(Format('SKU                      %s',[VarStrNull(colItem.SKU)]));// String
    Writeln(Format('SlotLayout               %s',[VarStrNull(colItem.SlotLayout)]));// String
    Writeln(Format('SpecialRequirements      %s',[VarStrNull(colItem.SpecialRequirements)]));// Boolean
    Writeln(Format('Status                   %s',[VarStrNull(colItem.Status)]));// String
    Writeln(Format('Tag                      %s',[VarStrNull(colItem.Tag)]));// String
    Writeln(Format('Version                  %s',[VarStrNull(colItem.Version)]));// String
    Writeln(Format('Weight                   %s',[VarStrNull(colItem.Weight)]));// Real32
    Writeln(Format('Width                    %s',[VarStrNull(colItem.Width)]));// Real32
    Writeln('');
    colItem:=Unassigned;
  end;
end;

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

Using Delphi .Net (Valid for versions 2005, 2006, 2007)

1) before to use the .net wmi objects you add the System.Management reference to your project.

2) Now we need make the connection to the WMi service, to do this you must use the System.Management namespace and the ManagementObjectSearcher class wich have several constructor to facilitate the connection with the wmi, this class is very versatile and let establish the connection and make a WQL query in a single step.

Check the constructors availables to this class

Public method ManagementObjectSearcher() 	//Initializes a new instance of the ManagementObjectSearcher class. After some properties on this object are set, the object can be used to invoke a query for management information. This is the default constructor.

 

Public method ManagementObjectSearcher(ObjectQuery) 	//Initializes a new instance of the ManagementObjectSearcher class used to invoke the specified query for management information.

 

Public method ManagementObjectSearcher(String) 	//Initializes a new instance of the ManagementObjectSearcher class used to invoke the specified query for management information.

 

Public method ManagementObjectSearcher(ManagementScope, ObjectQuery) //Initializes a new instance of the ManagementObjectSearcher class used to invoke the specified query in the specified scope.

 

Public method ManagementObjectSearcher(String, String) 	//Initializes a new instance of the ManagementObjectSearcher class used to invoke the specified query in the specified scope.

 

Public method ManagementObjectSearcher(ManagementScope, ObjectQuery, EnumerationOptions) 	//Initializes a new instance of the

 

Public method ManagementObjectSearcher class //to be used to invoke the specified query in the specified scope, with the specified options.

 

Public method ManagementObjectSearcher(String, String, EnumerationOptions) 	//Initializes a new instance of the ManagementObjectSearcher class used to invoke the specified query, in the specified scope, and with the specified options.

so to establishing the connection and make the query to the WMI you must write a code like this

Searcher  :=ManagementObjectSearcher.Create('root\cimv2','SELECT * FROM Win32_BaseBoard');

3) retrieve the data using the ManagementObjectCollection object.

4) get a enumerator to iterate over the data returned using a ManagementObjectEnumerator

    Collection:=Searcher.Get();//Get the data
    iter:=Collection.GetEnumerator;//create  a enumerator
    while(iter.MoveNext()) do//iterate over the enumerator

5) and finally to access to the value of an particular property we must use a ManagementObject object in this way

      WmiObject:=ManagementObject(iter.Current); //get the current element
      SerialNumber:=WmiObject['SerialNumber'];

This is the full source code to access the wmi from Delphi .Net from a console application

program WmiDelphi.Net;
{$APPTYPE CONSOLE}
uses
  System.Management,
  SysUtils;

procedure  GetWin32_BaseBoardInfo;
var
Searcher   : ManagementObjectSearcher ;
Collection : ManagementObjectCollection;
iter       : ManagementObjectCollection.ManagementObjectEnumerator;
WmiObject  : ManagementObject;
begin
  try
    Searcher  :=ManagementObjectSearcher.Create('SELECT * FROM Win32_BaseBoard'); //make the WMi query
    Collection:=Searcher.Get();//Get the data
    iter:=Collection.GetEnumerator;//create  a enumerator
    while(iter.MoveNext()) do//iterate over the enumerator
    begin
      WmiObject:=ManagementObject(iter.Current); //get the current element
         Writeln(Format('Caption                 %s',[WmiObject['Caption']]));
         Writeln(Format('ConfigOptions           %s',[WmiObject['ConfigOptions']]));
         Writeln(Format('CreationClassName       %s',[WmiObject['CreationClassName']]));
         Writeln(Format('Depth                   %s',[WmiObject['Depth']]));
         Writeln(Format('Description             %s',[WmiObject['Description']]));
         Writeln(Format('Height                  %s',[WmiObject['Height']]));
         Writeln(Format('HostingBoard            %s',[WmiObject['HostingBoard']]));
         Writeln(Format('HotSwappable            %s',[WmiObject['HotSwappable']]));
         Writeln(Format('InstallDate             %s',[WmiObject['InstallDate']]));
         Writeln(Format('Manufacturer            %s',[WmiObject['Manufacturer']]));
         Writeln(Format('Model                   %s',[WmiObject['Model']]));
         Writeln(Format('Name                    %s',[WmiObject['Name']]));
         Writeln(Format('OtherIdentifyingInfo    %s',[WmiObject['OtherIdentifyingInfo']]));
         Writeln(Format('PartNumber              %s',[WmiObject['PartNumber']]));
         Writeln(Format('PoweredOn               %s',[WmiObject['PoweredOn']]));
         Writeln(Format('Product                 %s',[WmiObject['Product']]));
         Writeln(Format('Removable               %s',[WmiObject['Removable']]));
         Writeln(Format('Replaceable             %s',[WmiObject['Replaceable']]));
         Writeln(Format('RequirementsDescription %s',[WmiObject['RequirementsDescription']]));
         Writeln(Format('RequiresDaughterBoard   %s',[WmiObject['RequiresDaughterBoard']]));
         Writeln(Format('SerialNumber            %s',[WmiObject['SerialNumber']]));
         Writeln(Format('SKU                     %s',[WmiObject['SKU']]));
         Writeln(Format('SlotLayout              %s',[WmiObject['SlotLayout']]));
         Writeln(Format('SpecialRequirements     %s',[WmiObject['SpecialRequirements']]));
         Writeln(Format('Status                  %s',[WmiObject['Status']]));
         Writeln(Format('Tag                     %s',[WmiObject['Tag']]));
         Writeln(Format('Version                 %s',[WmiObject['Version']]));
         Writeln(Format('Weight                  %s',[WmiObject['Weight']]));
         Writeln(Format('Width                   %s',[WmiObject['Width']]));
    end;
    Readln;
  except
    on E:Exception do
      Writeln(E.Classname, ': ', E.Message);
  end;
end;

begin
  try
    GetWin32_BaseBoardInfo;
    Readln;
  except
    on E:Exception do
      Writeln(E.Classname, ': ', E.Message);
  end;
end.

Using Delphi Prism

By far using .Net and delphi prism must be the easy way to access the WMI, because you don’t need to implement enumerators or helper functions to avoid nulls. therefore exists many resources of the WMI and .Net in the MSDN site.

1) to access the WMI from .Net you add the System.Management namespace which give you full access to the WMI.

2) Now using the ManagementObjectSearcher class in a single step you can establish a connection to the wmi service and make a WQL query.

Searcher := new ManagementObjectSearcher('root\cimv2','select * from Win32_BaseBoard');

3) for iterate over the WMI data you can use the great features of dephi-prism, how create a local variable in a for loop

for WmiObject : ManagementObject  in searcher.Get() do //in this single line you are creating a WmiObject to get access to the properties,and searcher.Get() return a enumerator that iterates through the ManagementObjectCollection.

Finally the Source code of a Delphi Prism console application to access the WMI.

namespace WmiDelphiPrism;

interface
uses
System,
System.Management,
System.Text;

type
    ConsoleApp = class
    private
        class method GetWin32_BaseBoardInfo;
    public
        class method Main;
    end;

implementation

class method ConsoleApp.Main;
begin
 try
    GetWin32_BaseBoardInfo;
    Console.Read();
 except on E: Exception do
  Console.WriteLine(E.ToString()+' Trace '+E.StackTrace );
 end;
end;

class method ConsoleApp.GetWin32_BaseBoardInfo;
var
Searcher : ManagementObjectSearcher;
begin
     Searcher := new ManagementObjectSearcher('root\cimv2','select * from Win32_BaseBoard');
        for WmiObject : ManagementObject  in searcher.Get() do
        begin
             Console.WriteLine('{0,-35} {1,-40}','Caption',WmiObject['Caption']);
             Console.WriteLine('{0,-35} {1,-40}','ConfigOptions',WmiObject['ConfigOptions']);
             Console.WriteLine('{0,-35} {1,-40}','CreationClassName',WmiObject['CreationClassName']);
             Console.WriteLine('{0,-35} {1,-40}','Depth',WmiObject['Depth']);
             Console.WriteLine('{0,-35} {1,-40}','Description',WmiObject['Description']);
             Console.WriteLine('{0,-35} {1,-40}','Height',WmiObject['Height']);
             Console.WriteLine('{0,-35} {1,-40}','HostingBoard',WmiObject['HostingBoard']);
             Console.WriteLine('{0,-35} {1,-40}','HotSwappable',WmiObject['HotSwappable']);
             Console.WriteLine('{0,-35} {1,-40}','InstallDate',WmiObject['InstallDate']);
             Console.WriteLine('{0,-35} {1,-40}','Manufacturer',WmiObject['Manufacturer']);
             Console.WriteLine('{0,-35} {1,-40}','Model',WmiObject['Model']);
             Console.WriteLine('{0,-35} {1,-40}','Name',WmiObject['Name']);
             Console.WriteLine('{0,-35} {1,-40}','OtherIdentifyingInfo',WmiObject['OtherIdentifyingInfo']);
             Console.WriteLine('{0,-35} {1,-40}','PartNumber',WmiObject['PartNumber']);
             Console.WriteLine('{0,-35} {1,-40}','PoweredOn',WmiObject['PoweredOn']);
             Console.WriteLine('{0,-35} {1,-40}','Product',WmiObject['Product']);
             Console.WriteLine('{0,-35} {1,-40}','Removable',WmiObject['Removable']);
             Console.WriteLine('{0,-35} {1,-40}','Replaceable',WmiObject['Replaceable']);
             Console.WriteLine('{0,-35} {1,-40}','RequirementsDescription',WmiObject['RequirementsDescription']);
             Console.WriteLine('{0,-35} {1,-40}','RequiresDaughterBoard',WmiObject['RequiresDaughterBoard']);
             Console.WriteLine('{0,-35} {1,-40}','SerialNumber',WmiObject['SerialNumber']);
             Console.WriteLine('{0,-35} {1,-40}','SKU',WmiObject['SKU']);
             Console.WriteLine('{0,-35} {1,-40}','SlotLayout',WmiObject['SlotLayout']);
             Console.WriteLine('{0,-35} {1,-40}','SpecialRequirements',WmiObject['SpecialRequirements']);
             Console.WriteLine('{0,-35} {1,-40}','Status',WmiObject['Status']);
             Console.WriteLine('{0,-35} {1,-40}','Tag',WmiObject['Tag']);
             Console.WriteLine('{0,-35} {1,-40}','Version',WmiObject['Version']);
             Console.WriteLine('{0,-35} {1,-40}','Weight',WmiObject['Weight']);
             Console.WriteLine('{0,-35} {1,-40}','Width',WmiObject['Width']);
        end;
end;
end.

Using Lazarus

The code necessary to access the WMI from Free-pascal using lazarus is very similar to the used in the Delphi win32 Late-binding., so i will show the differences only because the general idea is the same.

1) you must add the Windows unit to the uses clause because this unit contan the PULONG type which is required in some functions.

2) you don’t need call CoInitialize and CoUninitialize functions because both are initializated by the comobj unit

3) the helper function GetWMIObject must be modified to fit with the new types of parameteres required by the MkParseDisplayName function.

which is declarated like this (see the _para3 param which is of PULONG (^cardinal) type)

 function MkParseDisplayName(_para1:IBindCtx; _para2:POLESTR; out _para3:PULONG; out _para4:IMoniker):HRESULT;stdcall; external  'ole32.dll' name 'MkParseDisplayName';

and the modified helper function now look like this.

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

4) the function IEnumVARIANT.Next requires a Variant param

Function  Next(celt: ULONG; OUT rgVar: VARIANT;  pCeltFetched: pULONG=nil):HResult;StdCall;

so you must use it in this way

var
colItem : Variant;
//
//
//
while oEnum.Next(1, colItem, nil) = 0 do

5) finally if you wanna use the format function, you must aware which has some problems with variant values. so you must rewrite the code to show the info in this way.

    SDummy:=VarStrNull(colItem.Caption); //SDummy is a string
    Writeln(Format('Caption                  %s',[SDummy]));

Lazarus source code of console aplication to access the WMI

program WmiLazarus_LateBinding;

{$mode objfpc}

uses
   SysUtils,
   Variants,
   comobj,//required for the OleCheck and CoInitialize functions
   ActiveX,
   Windows;//required for the PULONG type

function VarArrayToStr(const vArray: variant): string;

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

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

    Result:=Result+']';
end;

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

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

//The Win32_BaseBoard class represents a base board (also known as a motherboard
//or system board).

procedure  GetWin32_BaseBoardInfo;
var
  objWMIService : OleVariant;
  colItems      : OleVariant;
  colItem       : Variant;
  oEnum         : IEnumvariant;
  SDummy        : string;
begin;
  objWMIService := GetWMIObject('winmgmts:\\localhost\root\CIMV2');
  colItems      := objWMIService.ExecQuery('SELECT * FROM Win32_BaseBoard','WQL',0);
  oEnum         := IUnknown(colItems._NewEnum) as IEnumVariant;
  while oEnum.Next(1, colItem, nil) = 0 do
  begin
    SDummy:=VarStrNull(colItem.Caption);
    Writeln(Format('Caption                  %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.ConfigOptions);
    Writeln(Format('ConfigOptions            %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.CreationClassName);
    Writeln(Format('CreationClassName        %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.Depth);
    Writeln(Format('Depth                    %s',[SDummy]));// Real32
    SDummy:=VarStrNull(colItem.Description);
    Writeln(Format('Description              %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.Height);
    Writeln(Format('Height                   %s',[SDummy]));// Real32
    SDummy:=VarStrNull(colItem.HostingBoard);
    Writeln(Format('HostingBoard             %s',[SDummy]));// Boolean
    SDummy:=VarStrNull(colItem.HotSwappable);
    Writeln(Format('HotSwappable             %s',[SDummy]));// Boolean
    SDummy:=VarStrNull(colItem.InstallDate);
    Writeln(Format('InstallDate              %s',[SDummy]));// Datetime
    SDummy:=VarStrNull(colItem.Manufacturer);
    Writeln(Format('Manufacturer             %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.Model);
    Writeln(Format('Model                    %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.Name);
    Writeln(Format('Name                     %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.OtherIdentifyingInfo);
    Writeln(Format('OtherIdentifyingInfo     %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.PartNumber);
    Writeln(Format('PartNumber               %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.PoweredOn);
    Writeln(Format('PoweredOn                %s',[SDummy]));// Boolean
    SDummy:=VarStrNull(colItem.Product);
    Writeln(Format('Product                  %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.Removable);
    Writeln(Format('Removable                %s',[SDummy]));// Boolean
    SDummy:=VarStrNull(colItem.Replaceable);
    Writeln(Format('Replaceable              %s',[SDummy]));// Boolean
    SDummy:=VarStrNull(colItem.RequirementsDescription);
    Writeln(Format('RequirementsDescription  %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.RequiresDaughterBoard);
    Writeln(Format('RequiresDaughterBoard    %s',[SDummy]));// Boolean
    SDummy:=VarStrNull(colItem.SerialNumber);
    Writeln(Format('SerialNumber             %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.SKU);
    Writeln(Format('SKU                      %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.SlotLayout);
    Writeln(Format('SlotLayout               %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.SpecialRequirements);
    Writeln(Format('SpecialRequirements      %s',[SDummy]));// Boolean
    SDummy:=VarStrNull(colItem.Status);
    Writeln(Format('Status                   %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.Tag);
    Writeln(Format('Tag                      %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.Version);
    Writeln(Format('Version                  %s',[SDummy]));// String
    SDummy:=VarStrNull(colItem.Weight);
    Writeln(Format('Weight                   %s',[SDummy]));// Real32
    SDummy:=VarStrNull(colItem.Width);
    Writeln(Format('Width                    %s',[SDummy]));// Real32
  end;

end;

begin
 try
   //CoInitialize(nil);   you don't need call this because is initializated by the comobj unit
    try
      GetWin32_BaseBoardInfo;
      Readln;
    finally
    //CoUninitialize;
    end;
 except
    on E:Exception do
    begin
        Writeln(E.Classname, ':', E.Message);
        Readln;
    end;
  end;
end.

So now you don’t have excuses to don’t use the WMI for pascal code. And remember which you have the WMI Delphi Code creator to help you.;)


4 Comments

Be careful when you import the Microsoft WMIScripting Library

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

Check this sample.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

 

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

Windows XP version information for the wbemdisp.TLB file

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

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

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

Child Type:         VarFileInfo
Translation:        1033/1200

Windows 7 version information for the wbemdisp.TLB file

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

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

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

Child Type:         VarFileInfo
Translation:        1033/1200

and now the dump of the wbemdisp.TLB file

Windows XP Version

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

Windows 7 Version

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

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

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

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

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


4 Comments

Creating a TinyUrl from Delphi

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

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

check the sample code to get the response

program DelphiTinyUrl;

{$APPTYPE CONSOLE}

uses
  WinInet,
  SysUtils;

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

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

and the response is

http://tinyurl.com/2ca52me


9 Comments

Create a SFX File with Delphi (Self Extracting Archives)

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

The logic goes like this

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

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

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

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

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

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

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

create a file called Stub.rc with this content

STUB RT_RCDATA "SfxExtractor.exe"

now compile the rc file

BRCC32.exe Stub.rc

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

{$R Stub.res}

4) Now the second project select a file to compress

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

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

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

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

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

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

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

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

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

Project SfxExtractor

{$SetPEFlags 1}  //  remove relocation table

unit MainSFX;

interface

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

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

var
  FrmMain: TFrmMain;

implementation
{$R *.dfm}

uses
ShlObj,
ZLib,
Common;

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

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

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

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

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

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

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

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

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

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

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

end.

Project CreateSFX

unit MainCreateSFX;

interface

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

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

var
  FrmCreateSFX: TFrmCreateSFX;

implementation

uses Common;

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

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

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

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

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

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

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

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

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

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

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

end.

Notes:

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

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

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

Check the full sourcecode on Github


5 Comments

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

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

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

Check the screenshots samples

Showing the location of a ip address in Google Maps

Showing the location of a ip address in Yahoo Maps

Showing the location of a ip address in Bing Maps

Showing the location of a ip address in OpenStreet Maps

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

the header declaration goes like this

type
   TCP_TABLE_CLASS = Integer;

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

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

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

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

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

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

var
FExtendedTcpTable : PMIB_TCPTABLE_OWNER_PID;

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

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

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

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

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

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

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

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

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

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

      finally
         FreeMem(FExtendedTcpTable);
      end;

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

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

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

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

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

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

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

    FListItem.MakeVisible(False);
end;

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

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

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

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

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

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

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

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

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

end;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Check the full source code on Github


7 Comments

Building a traceroute application with IP geolocation using Delphi

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

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

First we define the stucture to contain the geolocation data

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

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

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

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

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

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

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

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

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

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

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

Check the definition of the TGeoTraceThread TThread

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

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

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

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

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

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

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

    try

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

      TraceResp    := 0;
      FCurrentTTL  := 0;

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

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

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

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

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

          sValue:=sValue+FLogString;
        end;

        FLogString:=sValue+' ';

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

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

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

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

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

    finally
      IcmpCloseHandle(TraceHandle);
    end;

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

  finally
    WSACleanup;
  end;
end;

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

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

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

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

finally you can call the the TGeoTraceThread class in this way

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

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

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

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

Check the source code on Github

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