Home page > Delphi, tips bulk > For MS-Windows > Wintools: valuable tools for Windows

Wintools: valuable tools for Windows

Sunday 28 August 2011, by CapJack

This Delphi unit contains some useful functions using the Windows API.

Compatibility:
Delphi all non-.NET versions, including XE2.
Lazarus 32/64 bits, from 0.9.25, tested on 0.9.30.

Target platform:
Windows 32/64 bits.

I’m not asking anything in return for this work, except a small link to my site if you find it useful and use it in your software.

Revisions :
September 3 2011 : great job of adaptation for Lazarus.

  1. (*********************************************************)
  2. (***)                                                 (***)
  3. (***)                UNIT WinTools;                   (***)
  4. (***)                                                 (***)
  5. (*********************************************************)
  6.  
  7. (*********************************************************)
  8. (* Feel free to use it, but at your own risk!            *)
  9. (* À utiliser librement, mais à vos risques et périls !  *)
  10. (* CapJack.                                              *)
  11. (*********************************************************)
  12.  
  13.  
  14. (*********************************************************)
  15. (***)                                                 (***)
  16. (***)                  INTERFACE                      (***)
  17. (***)                                                 (***)
  18. (*********************************************************)
  19.  
  20. {$WARN UNIT_PLATFORM OFF}
  21. {$IFDEF MSWindows}
  22.  {$IFDEF FPC} // Lazarus / Free Pascal
  23.    uses Windows, SysUtils, Classes, Forms, LCLProc;
  24.  {$ELSE} // Delphi
  25.   {$IFDEF DCC} // Delphi XE2 Win 32/64
  26.    uses WinAPI.Windows, System.SysUtils, VCL.Forms;
  27.   {$ELSE} // Delphi other
  28.    uses Windows, SysUtils, Forms;
  29.   {$ENDIF DCC}
  30.  {$ENDIF FPC}
  31. {$ELSE}
  32.  'MS-Windows only!'
  33. {$ENDIF MSWindows}
  34.  
  35.  
  36. {$IFDEF FPC}
  37. type
  38.   PWindowInfo = ^TWindowInfo;
  39.   TWINDOWINFO = packed record
  40.     cbSize: DWORD;
  41.     rcWindow: TRect;
  42.     rcClient: TRect;
  43.     dwStyle: DWORD;
  44.     dwExStyle: DWORD;
  45.     dwOtherStuff: DWORD;
  46.     cxWindowBorders: UINT;
  47.     cyWindowBorders: UINT;
  48.     atomWindowType: TAtom;
  49.     wCreatorVersion: WORD;
  50.   end;
  51. function GetWindowInfo
  52.          (hwnd: HWND; var pwi: TWindowInfo): BOOL; stdcall;
  53. function GetEnvironmentVariable
  54.          (lpName: PWideChar; lpBuffer: PWideChar;
  55.           nSize: DWORD): DWORD; stdcall;
  56. {$ENDIF FPC}
  57.  
  58. (*********************************************************)
  59. (* DTCharInSet                                           *)
  60. (* ----------------------------------------------------- *)
  61. (* Test the membership of a char in a character set,     *)
  62. (* compatible with all versions of Delphi,               *)
  63. (* avoid corresponding warning of Delphi 2009.           *)
  64. (* ----------------------------------------------------- *)
  65. (* Teste l'appartenance d'un caractère à un ensemble,    *)
  66. (* compatible toutes versions de Delphi,                 *)
  67. (* évite le warning correspondant de Delphi 2009.        *)
  68. (*********************************************************)
  69.  
  70. type    {$IFDEF FPC} // Lazarus
  71.         SetOfChar = TSysCharSet;
  72.         {$ELSE} // Delphi
  73.         {$IFDEF UNICODE}
  74.         SetOfChar = TSysCharSet;
  75.         {$ELSE}
  76.         SetOfChar = set of Char;
  77.         {$ENDIF UNICODE}
  78.         {$ENDIF FPC}
  79.  
  80. Function  DTCharInSet
  81.           (
  82.           C             : Char;
  83.           const CharSet : SetOfChar
  84.           ): Boolean;
  85.  
  86. (*********************************************************)
  87. (* DTGetWindowsErrorText                                 *)
  88. (* ----------------------------------------------------- *)
  89. (* Returns the Windows error message corresponding       *)
  90. (* to the code transmitted, typically GetLastError.      *)
  91. (* ----------------------------------------------------- *)
  92. (* Renvoie le message d'erreur Windows correspondant     *)
  93. (* au code transmis, typiquement GetLastError.           *)
  94. (*********************************************************)
  95.  
  96. Function  DTGetWindowsErrorText
  97.           (
  98.           Error:Integer
  99.           ): string;
  100.  
  101. (*********************************************************)
  102. (* DTGetWindowsLastError                                 *)
  103. (* ----------------------------------------------------- *)
  104. (* Returns in the form of an explicit text, the last     *)
  105. (* error caused in Windows.                              *)
  106. (* Very useful for catching exceptions.                  *)
  107. (* ----------------------------------------------------- *)
  108. (* Renvoie, sous forme de texte explicite, le dernier    *)
  109. (* message d'erreur provoqué dans Windows.               *)
  110. (* Très pratique pour l'interception des exceptions.     *)
  111. (*********************************************************)
  112.  
  113. Function  DTGetWindowsLastError: string;
  114.  
  115. (*********************************************************)
  116. (* DTGetWindowsDirectory                                 *)
  117. (* ----------------------------------------------------- *)
  118. (* Returns the Windows directory.                        *)
  119. (* ----------------------------------------------------- *)
  120. (* Renvoie le répertoire de Windows.                     *)
  121. (*********************************************************)
  122.  
  123. Function  DTGetWindowsDirectory: string;
  124.  
  125. (*********************************************************)
  126. (* DTGetSystemDirectory                                  *)
  127. (* ----------------------------------------------------- *)
  128. (* Returns the Windows system directory.                 *)
  129. (* ----------------------------------------------------- *)
  130. (* Renvoie le répertoire système de Windows.             *)
  131. (*********************************************************)
  132.  
  133. Function  DTGetSystemDirectory: string;
  134.  
  135. (*********************************************************)
  136. (* DTGetShellPath                                        *)
  137. (* ----------------------------------------------------- *)
  138. (* Returns the full path to the dll "SHELL32.DLL"        *)
  139. (* ----------------------------------------------------- *)
  140. (* Renvoie le chemin complet de la dll "SHELL32.DLL"     *)
  141. (*********************************************************)
  142.  
  143. Function  DTGetShellPath: string;
  144.  
  145. (*********************************************************)
  146. (* DTGlobalSharedLockedAlloc                             *)
  147. (* ----------------------------------------------------- *)
  148. (* Allocate and lock a block of shared memory            *)
  149. (* of the given capacity. The handle is returned in hMem *)
  150. (* and the pointer as the return value.                  *)
  151. (* ----------------------------------------------------- *)
  152. (* Alloue et verrouille un bloc de mémoire partagée de   *)
  153. (* la capacité indiquée. Le handle est renvoyé dans hMem *)
  154. (* et le pointeur comme valeur de retour.                *)
  155. (*********************************************************)
  156.  
  157. Function  DTGlobalSharedLockedAlloc
  158.           (
  159.           Capacity : Word;
  160.           var hMem : HGLOBAL
  161.           ): Pointer;
  162.  
  163. (*********************************************************)
  164. (* DTGlobalSharedLockedFree                              *)
  165. (* ----------------------------------------------------- *)
  166. (* Unlocks and releases the memory block                 *)
  167. (* of Handle hMEM. Note: The Ptr parameter is unused     *)
  168. (* (It was in Windows 16 bits).                          *)
  169. (* ----------------------------------------------------- *)
  170. (* Déverrouille, puis libère le bloc de mémoire de       *)
  171. (* handle hMEM. Note : le paramètre Ptr est inutilisé    *)
  172. (* (il l'était dans Windows 16 bits).                    *)
  173. (*********************************************************)
  174.  
  175. Procedure DTGlobalSharedLockedFree
  176.           (
  177.           hMem : HGLOBAL;
  178.           Ptr  : Pointer = nil
  179.           );
  180.  
  181. (*********************************************************)
  182. (* DTExitWindows                                         *)
  183. (* ----------------------------------------------------- *)
  184. (* Close or restart Windows. Examples:                   *)
  185. (* DTExitWindows(EWX_POWEROFF or EWX_FORCE);             *)
  186. (* DTExitWindows(EWX_REBOOT or EWX_FORCE);               *)
  187. (* ----------------------------------------------------- *)
  188. (* Ferme ou redémarre Windows. Exemples :                *)
  189. (* DTExitWindows(EWX_POWEROFF or EWX_FORCE);             *)
  190. (* DTExitWindows(EWX_REBOOT or EWX_FORCE);               *)
  191. (*********************************************************)
  192.  
  193. function  DTExitWindows
  194.           (
  195.           RebootParam : Longword
  196.           ): Boolean;
  197.  
  198. (*********************************************************)
  199. (* DTGetPriorityClassDescriptor                          *)
  200. (* ----------------------------------------------------- *)
  201. (* Returns a string describing the given                 *)
  202. (* priority parameter.                                   *)
  203. (* ----------------------------------------------------- *)
  204. (* Renvoie une chaîne decrivant le paramètre de          *)
  205. (* priorité transmis.                                    *)
  206. (*********************************************************)
  207.  
  208. const BELOW_NORMAL_PRIORITY_CLASS = $4000;
  209.       ABOVE_NORMAL_PRIORITY_CLASS = $8000;
  210.  
  211. function  DTGetPriorityClassDescriptor
  212.           (
  213.           Priority : Integer
  214.           ): string;
  215.  
  216. (*********************************************************)
  217. (* DTClickHWND                                           *)
  218. (* ----------------------------------------------------- *)
  219. (* Triggers a left mouse click in the window Wnd,        *)
  220. (* to the relative coordinates (XRel; YRel),             *)
  221. (* then wait a given time (in ms).                       *)
  222. (* I decline all responsibility for the use              *)
  223. (* you will make. :)                                     *)
  224. (* ----------------------------------------------------- *)
  225. (* Déclenche un clic gauche de souris dans la fenêtre    *)
  226. (* Wnd, aux coordonnées relatives (XRel;YRel),           *)
  227. (* puis attend le temps précisé (en ms).                 *)
  228. (* Je décline toute responsabilité quant à l'utilisation *)
  229. (* que vous en ferez. :)                                 *)
  230. (*********************************************************)
  231.  
  232. procedure DTClickHWND
  233.           (
  234.           const Wnd        : HWND;
  235.           const XRel, YRel : integer;
  236.           const WaitTime   : integer = 200
  237.           );
  238.  
  239. (*********************************************************)
  240. (* DTAnsiToOEM                                           *)
  241. (* ----------------------------------------------------- *)
  242. (* Conversion Ansi to DOS characters,                    *)
  243. (* based on the current code page.                       *)
  244. (* ----------------------------------------------------- *)
  245. (* Conversion Ansi en caractères DOS,                    *)
  246. (* basée sur la page  de code courante.                  *)
  247. (*********************************************************)
  248.  
  249. Function  DTAnsiToOem
  250.           (
  251.           Source : AnsiString
  252.           ): AnsiString;
  253.  
  254. (*********************************************************)
  255. (* DTOEMToAnsi                                           *)
  256. (* ----------------------------------------------------- *)
  257. (* Conversion DOS (current code page) to ANSI.           *)
  258. (* ----------------------------------------------------- *)
  259. (* Conversion DOS (page de code courante) en ANSI.       *)
  260. (*********************************************************)
  261.  
  262. Function  DTOemToAnsi
  263.           (
  264.           Source : AnsiString
  265.           ): AnsiString;
  266.  
  267. (*********************************************************)
  268. (* DTASCIIToAnsi                                         *)
  269. (* ----------------------------------------------------- *)
  270. (* Conversion ASCII to ANSI.                             *)
  271. (* ----------------------------------------------------- *)
  272. (* Conversion ASCII en ANSI.                             *)
  273. (*********************************************************)
  274.  
  275. function  DTAsciiToAnsi
  276.           (
  277.           const Source : AnsiString
  278.           ): string;
  279.  
  280. (*********************************************************)
  281. (* DTWideStringToAnsiString                              *)
  282. (* ----------------------------------------------------- *)
  283. (* Conversion Wide string to Ansi string                 *)
  284. (* with the given code page.                             *)
  285. (* ----------------------------------------------------- *)
  286. (* Conversion chaîne Wide en chaîne Ansi                 *)
  287. (* de la page de code indiquée.                          *)
  288. (*********************************************************)
  289.  
  290. function DTWideStringToAnsiString
  291.          (
  292.          const ws : WideString;
  293.          CodePage : Word = CP_ACP
  294.          ): AnsiString;
  295.  
  296. (*********************************************************)
  297. (* DTAnsiStringToWideString                              *)
  298. (* ----------------------------------------------------- *)
  299. (* Conversion Ansi string to Wide string                 *)
  300. (* with the given code page.                             *)
  301. (* ----------------------------------------------------- *)
  302. (* Conversion chaîne Ansi de la page de code indiquée,   *)
  303. (* en chaîne Wide.                                       *)
  304. (*********************************************************)
  305.  
  306. function DTAnsiStringToWideString
  307.          (
  308.          const s  : AnsiString;
  309.          CodePage : Word = CP_ACP
  310.          ): WideString;
  311.  
  312. (*********************************************************)
  313. (* DTAnsiStringToString                                  *)
  314. (* DTWideStringToString                                  *)
  315. (* DTStringToAnsiString                                  *)
  316. (* DTStringToWideString                                  *)
  317. (* ----------------------------------------------------- *)
  318. (* String conversion from/to the string type             *)
  319. (* dependent of the Delphi version, taking into account  *)
  320. (* the current code page.                                *)
  321. (* ----------------------------------------------------- *)
  322. (* Conversion de chaîne vers/depuis le type string       *)
  323. (* dépendant de la version de Delphi, en tenant compte   *)
  324. (* de la page de code courante.                          *)
  325. (*********************************************************)
  326.  
  327. function DTAnsiStringToString(s:AnsiString): string;
  328. function DTWideStringToString(s:WideString): string;
  329. function DTStringToAnsiString(s:string): AnsiString;
  330. function DTStringToWideString(s:string): WideString;
  331.  
  332. (*********************************************************)
  333. (* Structures used by management functions               *)
  334. (* for version and date of executable files.             *)
  335. (* The variable DTApp is an example of such data,        *)
  336. (* and can be set for the appication itself              *)
  337. (* for example, using DTGetFileVersTimeInfos ('', DTApp) *)
  338. (* ----------------------------------------------------- *)
  339. (* Structures utilisées par les fonctions de gestion     *)
  340. (* de version et de date de fichiers exécutables.        *)
  341. (* La variable DTApp est un exemple de telles données,   *)
  342. (* et peut être initialisée, pour l'appication elle-même *)
  343. (* par exemple, par DTGetFileVersTimeInfos('',DTApp);    *)
  344. (*********************************************************)
  345.  
  346. type TDTVersInfos =
  347.      record
  348.       VersionStr   : string;
  349.       Major        : Cardinal;
  350.       Minor        : Cardinal;
  351.       Build        : Cardinal;
  352.       Release      : Cardinal;
  353.       Version      : Cardinal;
  354.       Debug        : Boolean;
  355.       PreRelease   : Boolean;
  356.       Patched      : Boolean;
  357.       PrivateBuild : Boolean;
  358.       InfoInferred : Boolean;
  359.       SpecialBuild : Boolean;
  360.      end;
  361.  
  362.      TDTTimeInfos =
  363.      record
  364.       Year,Month,Day,Hour,Min,Sec,MSec : Word;
  365.      end;
  366.  
  367.      TDTVersTimeInfos =
  368.      record
  369.       vers : TDTVersInfos;
  370.       time : TDTTimeInfos;
  371.      end;
  372.  
  373. var DTApp : TDTVersTimeInfos;
  374.  
  375. (*********************************************************)
  376. (* DTGetFileAge                                          *)
  377. (* ----------------------------------------------------- *)
  378. (* Returns a TDateTime structure with age of the file.   *)
  379. (* ----------------------------------------------------- *)
  380. (* Renvoie une structure TDateTime avec l'âge du fichier.*)
  381. (*********************************************************)
  382.  
  383. function DTGetFileAge
  384.          (
  385.          const AFileName : string
  386.          ): TDateTime;
  387.  
  388. (*********************************************************)
  389. (* DTFileAge                                             *)
  390. (* ----------------------------------------------------- *)
  391. (* Returns the integer file timestamp                    *)
  392. (* (equivalent to the deprecated FileAge)                *)
  393. (* ----------------------------------------------------- *)
  394. (* Renvoie le timestamp entier du fichier                *)
  395. (* (équivalent au FileAge déprécié)                      *)
  396. (*********************************************************)
  397.  
  398. function DTFileAge
  399.          (
  400.          const AFileName : string
  401.          ): Integer;
  402.  
  403. (*********************************************************)
  404. (* DTGetFileVersInfos                                    *)
  405. (* ----------------------------------------------------- *)
  406. (* Fill in the structure "Info" with the version         *)
  407. (* information of "AFileName."                           *)
  408. (* ----------------------------------------------------- *)
  409. (* Renseigne la structure "Info" avec les informations   *)
  410. (* de version de "AFileName".                            *)
  411. (*********************************************************)
  412.  
  413. procedure DTGetFileVersInfos
  414.           (
  415.           const AFileName : string;
  416.           var   Info      : TDTVersInfos
  417.           );
  418.  
  419. (*********************************************************)
  420. (* DTGetFileTimeInfos                                    *)
  421. (* ----------------------------------------------------- *)
  422. (* Fill in the structure "Info" with the datation        *)
  423. (* information of "AFileName."                           *)
  424. (* ----------------------------------------------------- *)
  425. (* Renseigne la structure "Info" avec les informations   *)
  426. (* de datation de "AFileName".                           *)
  427. (*********************************************************)
  428.  
  429. procedure DTGetFileTimeInfos
  430.           (
  431.           const AFileName : string;
  432.           var   Info      : TDTTimeInfos
  433.           );
  434.  
  435. (*********************************************************)
  436. (* DTGetFileVersTimeInfos                                *)
  437. (* ----------------------------------------------------- *)
  438. (* Combines the previous two functions into one.         *)
  439. (* ----------------------------------------------------- *)
  440. (* Combine les deux fonctions précédentes en une seule.  *)
  441. (*********************************************************)
  442.  
  443. procedure DTGetFileVersTimeInfos
  444.           (
  445.           const AFileName : string;
  446.           var   Info      : TDTVersTimeInfos
  447.           );
  448.  
  449. (*********************************************************)
  450. (* DTFormatVersTimeInfos                                 *)
  451. (* ----------------------------------------------------- *)
  452. (* Transforms data from a TDTVersTimeInfos structure     *)
  453. (* into a string readable for the user.                  *)
  454. (* Formatting marks to be used in the string "AFormat"   *)
  455. (* %0:s  > VersionStr  %1:d  > Major    %2:d  > Minor    *)
  456. (* %3:d  > Build       %4:d  > Release  %5:d  > Version  *)
  457. (* %6:d  > Year        %7:d  > Month    %8:d  > Day      *)
  458. (* %9:d  > Hour        %10:d > Min      %11:d > Sec      *)
  459. (* %12:d > MSec                                          *)
  460. (* ----------------------------------------------------- *)
  461. (* Transforme les données d'un TDTVersTimeInfos          *)
  462. (* en chaîne lisible pour l'utilisateur.                 *)
  463. (* Marques de format à utiliser dans la chaîne "AFormat" *)
  464. (* %0:s  > VersionStr  %1:d  > Major    %2:d  > Minor    *)
  465. (* %3:d  > Build       %4:d  > Release  %5:d  > Version  *)
  466. (* %6:d  > Year        %7:d  > Month    %8:d  > Day      *)
  467. (* %9:d  > Hour        %10:d > Min      %11:d > Sec      *)
  468. (* %12:d > MSec                                          *)
  469. (*********************************************************)
  470.  
  471. function  DTFormatVersTimeInfos
  472.           (
  473.           const AFormat : string;
  474.           var   Info    : TDTVersTimeInfos
  475.           ): string;
  476.  
  477. (*********************************************************)
  478. (* DTGetShellFolder                                      *)
  479. (* ----------------------------------------------------- *)
  480. (* Returns the Shell folder as defined in the Registry.  *)
  481. (* ----------------------------------------------------- *)
  482. (* Renvoie le dossier Shell tel que défini dans la base  *)
  483. (* de registres.                                         *)
  484. (*********************************************************)
  485.  
  486. // Don't localize. List can be completed.
  487. // Ne pas localiser. La liste peut être complétée.
  488. const   shfold_Personal            ='Personal';
  489.         shfold_Favorites           ='Favorites';
  490.         shfold_Cache               ='Cache';
  491.         shfold_AppData             ='AppData';
  492.         shfold_Desktop             ='Desktop';
  493.         shfold_Recent              ='Recent';
  494.         shfold_NetHood             ='NetHood';
  495.         shfold_StartMenu           ='Start Menu';
  496.         shfold_Programs            ='Programs';
  497.         shfold_Startup             ='Startup';
  498.         shfold_Cookies             ='Cookies';
  499.         shfold_History             ='History';
  500.         shfold_Fonts               ='Fonts';
  501.         shfold_SendTo              ='SendTo';
  502.         shfold_PrintHood           ='PrintHood';
  503.         shfold_MyPictures          ='My Pictures';
  504.         shfold_LocalAppData        ='Local AppData';
  505.         shfold_Templates           ='Templates';
  506.         shfold_AdministrativeTools ='Administrative Tools';
  507.         shfold_MyMusic             ='My Music';
  508.  
  509. Function  DTGetShellFolder
  510.           (
  511.           const Folder: string
  512.           ): string;
  513.  
  514. (*********************************************************)
  515. (* DTGetEnvironmentVariable                              *)
  516. (* ----------------------------------------------------- *)
  517. (* Returns the contents of the given environment         *)
  518. (* variable.                                             *)
  519. (* ----------------------------------------------------- *)
  520. (* Renvoie le contenu de la variable d'environnement     *)
  521. (* transmise.                                            *)
  522. (*********************************************************)
  523.  
  524. Function  DTGetEnvironmentVariable
  525.           (
  526.           EnvVar:string
  527.           ): string;
  528.  
  529. (*********************************************************)
  530. (* DTFilterEnvVars                                       *)
  531. (* ----------------------------------------------------- *)
  532. (* Filter string (eg path), replacing the current        *)
  533. (* environment variables by their values.        *)
  534. (* ----------------------------------------------------- *)
  535. (* Filtre une chaîne de caractères (chemin par exemple)  *)
  536. (* en remplaçant les variables d'environnement présentes *)
  537. (* par leurs valeurs.                                    *)
  538. (*********************************************************)
  539.  
  540. Function  DTFilterEnvVars
  541.           (
  542.           Path:string
  543.           ): string;
  544.  
  545. (*********************************************************)
  546. (* DTRegReadString                                       *)
  547. (* ----------------------------------------------------- *)
  548. (* Read a string value in the Registry.                  *)
  549. (* ----------------------------------------------------- *)
  550. (* Lit une valeur chaîne dans la base de registres.      *)
  551. (*********************************************************)
  552.  
  553. Function  DTRegReadString
  554.           (
  555.           HRoot : HKEY;
  556.           SSection, SKey, SDefValue : String
  557.           ): String;
  558.  
  559. (*********************************************************)
  560. (* DTBrowse                                              *)
  561. (* ----------------------------------------------------- *)
  562. (* Open a URL in the default browser.                    *)
  563. (* ----------------------------------------------------- *)
  564. (* Ouvre une URL dans le navigateur par défaut.          *)
  565. (*********************************************************)
  566.  
  567. Procedure DTBrowse
  568.           (
  569.           AnURL : string
  570.           );
  571.  
  572. (*********************************************************)
  573. (* DTFolderPersonal                                      *)
  574. (* ----------------------------------------------------- *)
  575. (* Returns the directory of the user.                    *)
  576. (* Example: "C:\Documents and Settings\Booby"          *)
  577. (* ----------------------------------------------------- *)
  578. (* Renvoie le répertoire personnel de l'utilisateur.     *)
  579. (* Exemple : "C:\Documents and Settings\Duduche"         *)
  580. (*********************************************************)
  581.  
  582. Function  DTFolderPersonal: string;
  583.  
  584.  
  585. (*********************************************************)
  586. (***)                                                 (***)
  587. (***)                 IMPLEMENTATION                  (***)
  588. (***)                                                 (***)
  589. (*********************************************************)
  590.  
  591. const MiscBufferSize = 32 * 1024; // should be enough
  592.  
  593. // Utility functions for Lazarus. FPC is NOT Unicode.
  594. // Fonctions utilitaires pour Lazarus. FPC n'est PAS Unicode.
  595. // http://wiki.lazarus.freepascal.org/LCL_Unicode_Support
  596.  
  597. {$IFDEF FPC} // Lazarus
  598. type
  599.  TMiscBuffer = array[0..MiscBufferSize] of AnsiChar;
  600.  TFileBuffer = array[0..MAX_PATH] of AnsiChar;
  601.  
  602. function ToAPI(s:string):AnsiString;
  603.  begin
  604.   Result := UTF8ToAnsi(s)
  605.  end;
  606.  
  607. function FromAPI(s:AnsiString):string;
  608.  begin
  609.   Result := AnsiToUTF8(s)
  610.  end;
  611.  
  612. {$ELSE} // Delphi
  613. type
  614.  TMiscBuffer = array[0..MiscBufferSize] of Char;
  615.  TFileBuffer = array[0..MAX_PATH] of Char;
  616.  
  617. function ToAPI(s:string):string;
  618.  begin
  619.   Result := s
  620.  end;
  621.  
  622. function FromAPI(s:string):string;
  623.  begin
  624.   Result := s
  625.  end;
  626.  
  627. {$ENDIF FPC}
  628.  
  629. {---------------------------------------------------------}
  630.  
  631. Function  DTCharInSet
  632.           (
  633.           C             : Char;
  634.           const CharSet : SetOfChar
  635.           ): Boolean;
  636.  begin
  637.   {$IFDEF FPC} // Lazarus
  638.   Result := C in CharSet
  639.   {$ELSE} // Delphi
  640.   {$IFDEF UNICODE}
  641.   Result := CharInSet(C,CharSet)
  642.   {$ELSE}
  643.   Result := C in CharSet
  644.   {$ENDIF UNICODE}
  645.   {$ENDIF FPC}
  646.  end;
  647.  
  648. {---------------------------------------------------------}
  649.  
  650. Function  DTGetWindowsErrorText
  651.           (
  652.           Error:Integer
  653.           ): string;
  654. var Buffer:TMiscBuffer;Str:string;
  655.  begin
  656.   Result := '';
  657.   FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,nil,Error,0,
  658.                 @Buffer,SizeOf(Buffer),nil);
  659.   Str := FromAPI(StrPas(Buffer));
  660.   while (Length(Str)>0)
  661.     and DTCharInSet(Str[Length(Str)],[#13,#10])
  662.         do Delete(Str,Length(Str),1);
  663.   Result := Str;
  664.  end;
  665.  
  666. {---------------------------------------------------------}
  667.  
  668. Function  DTGetWindowsLastError: string;
  669.  begin
  670.   Result := DTGetWindowsErrorText(GetLastError);
  671.  end;
  672.  
  673. {---------------------------------------------------------}
  674.  
  675. Function  DTGetWindowsDirectory: string;
  676. var buffer:TFileBuffer;
  677. begin
  678.  GetWindowsDirectory(@buffer,SizeOf(Buffer));
  679.  Result:=FromAPI(StrPas(Buffer));
  680. end;
  681.  
  682. {---------------------------------------------------------}
  683.  
  684. Function  DTGetSystemDirectory: string;
  685. var buffer:TFileBuffer;
  686. begin
  687.  GetSystemDirectory(@buffer,SizeOf(Buffer));
  688.  Result:=FromAPI(StrPas(Buffer));
  689. end;
  690.  
  691. {---------------------------------------------------------}
  692.  
  693. Function  DTGetShellPath: string;
  694. begin
  695.  Result
  696.   := IncludeTrailingPathDelimiter(DTGetSystemDirectory)
  697.      + 'SHELL32.DLL'
  698. end;
  699.  
  700. {---------------------------------------------------------}
  701.  
  702. Function  DTGlobalSharedLockedAlloc
  703.           (
  704.           Capacity : Word;
  705.           var hMem : HGLOBAL
  706.           ): Pointer;
  707. var
  708.         ptr: Pointer;
  709. begin
  710.         hMem := GlobalAlloc(GMEM_SHARE Or GMEM_MOVEABLE
  711.                       Or GMEM_ZEROINIT, Capacity );
  712.         if (hMem = 0) then ptr := Nil
  713.                       else begin
  714.                             ptr := GlobalLock(hMem);
  715.                             if (ptr = Nil)
  716.                                then GlobalFree(hMem);
  717.                            end;
  718.         Result := Ptr;
  719. end;
  720.  
  721. {---------------------------------------------------------}
  722.  
  723. Procedure DTGlobalSharedLockedFree
  724.           (
  725.           hMem : HGLOBAL;
  726.           Ptr  : Pointer = nil
  727.           );
  728. begin
  729.         if (hMem <> 0)
  730.      then begin
  731.            GlobalUnlock(hMem);
  732.            GlobalFree(hMem);
  733.           end;
  734. end;
  735.  
  736. {---------------------------------------------------------}
  737.  
  738. function  DTExitWindows
  739.           (
  740.           RebootParam : Longword
  741.           ): Boolean;
  742. var
  743.   hToken  : THandle;
  744.   tkp     : TTokenPrivileges;
  745.   rtkp    : TTokenPrivileges;
  746.   cbtp    : DWORD;
  747.   pcbtppr : DWORD;
  748. const
  749.   SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
  750. begin
  751.  Result := false;
  752.  
  753.  if Win32Platform = VER_PLATFORM_WIN32_NT then
  754.    begin
  755.     if not(OpenProcessToken(GetCurrentProcess(),
  756.        TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
  757.        hToken)) then begin exit end;
  758.  
  759.     // Get the LUID for the shutdown privilege.
  760.  
  761.     LookupPrivilegeValue(nil,SE_SHUTDOWN_NAME,
  762.                          tkp.Privileges[0].Luid);
  763.  
  764.     tkp.PrivilegeCount := 1;
  765.     tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
  766.     cbtp := SizeOf(rtkp);
  767.     pcbtppr := 0;
  768.  
  769.     AdjustTokenPrivileges(hToken,False,tkp,cbtp,
  770.                           rtkp,pcbtppr);
  771.  
  772.     if GetLastError <> ERROR_SUCCESS then exit;
  773.   end;
  774.  Result := ExitWindowsEx(RebootParam, 0);
  775. end;
  776.  
  777. {---------------------------------------------------------}
  778.  
  779. function  DTGetPriorityClassDescriptor
  780.           (
  781.           Priority : Integer
  782.           ): string;
  783. begin
  784.  case Priority of
  785.  
  786.         IDLE_PRIORITY_CLASS
  787.          : Result := 'IDLE_PRIORITY_CLASS';
  788.  
  789.         BELOW_NORMAL_PRIORITY_CLASS
  790.          : Result := 'BELOW_NORMAL_PRIORITY_CLASS';
  791.  
  792.         NORMAL_PRIORITY_CLASS
  793.          : Result := 'NORMAL_PRIORITY_CLASS';
  794.  
  795.         ABOVE_NORMAL_PRIORITY_CLASS
  796.          : Result := 'ABOVE_NORMAL_PRIORITY_CLASS';
  797.  
  798.         HIGH_PRIORITY_CLASS
  799.          : Result := 'HIGH_PRIORITY_CLASS';
  800.  
  801.         REALTIME_PRIORITY_CLASS
  802.          : Result := 'REALTIME_PRIORITY_CLASS';
  803.  
  804.         else Result := '?';
  805.  
  806.        end;
  807. end;
  808.  
  809. {---------------------------------------------------------}
  810.  
  811.  
  812. function GetWindowInfo
  813.          (hwnd: HWND; var pwi: TWindowInfo): BOOL; stdcall;
  814.          external user32 name 'GetWindowInfo';
  815.  
  816. procedure DTClickHWND
  817.           (
  818.           const Wnd        : HWND;
  819.           const XRel, YRel : integer;
  820.           const WaitTime   : integer = 200
  821.           );
  822.  var OldMousePos : TPoint;
  823.      X,Y:Integer;
  824.      Info:TWindowInfo;
  825.  begin
  826.   if GetForeGroundWindow <> Wnd then
  827.    begin
  828.     SetForeGroundWindow(Wnd);
  829.     Sleep(WaitTime);
  830.    end;
  831.   // Saves the current position of the mouse
  832.   // and retrieves information from the window.
  833.   // Sauvegarde la position actuelle de la souris
  834.   // et récupère les informations de la fenêtre.
  835.   GetCursorPos(OldMousePos);
  836.   GetWindowInfo(Wnd,Info);
  837.   // Calculation of absolute coordinates.
  838.   // Negative value =>
  839.   //             counted from the right, resp. the bottom.
  840.   // Calcul des coordonnées absolues.
  841.   // Valeur négative =>
  842.   //             comptée de la droite, resp. du bas.
  843.   if XRel >= 0
  844.    then X := Info.rcClient.Left   + XRel
  845.    else X := Info.rcClient.Right  + XRel;
  846.   if YRel >= 0
  847.    then Y := Info.rcClient.Top    + YRel
  848.    else Y := Info.rcClient.Bottom + YRel;
  849.   // Set the desired window in the foreground,
  850.   // then simulates the click of a mouse.
  851.   // Met la fenêtre voulue en avant-plan,
  852.   // puis simule le click de souris.
  853.   if GetForeGroundWindow <> Wnd then
  854.    begin
  855.     SetForeGroundWindow(Wnd);
  856.     Sleep(WaitTime);
  857.    end;
  858.   SetCursorPos(X,Y);
  859.   mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
  860.   Sleep(WaitTime);
  861.   mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);
  862.   // Restoration of the old mouse position.
  863.   // Restauration de l'ancienne position de la souris.
  864.   SetCursorPos(OldMousePos.X, OldMousePos.Y);
  865.  end;
  866.  
  867. {---------------------------------------------------------}
  868.  
  869. Function  DTAnsiToOem
  870.           (
  871.           Source : AnsiString
  872.           ): AnsiString;
  873. begin
  874.  SetLength(Result,Length(Source));
  875.  AnsiToOem(PAnsiChar(Source),PAnsiChar(Result));
  876. end;
  877.  
  878. {---------------------------------------------------------}
  879.  
  880. Function  DTOemToAnsi
  881.           (
  882.           Source : AnsiString
  883.           ): AnsiString;
  884. begin
  885.  SetLength(Result,Length(Source));
  886.  OemToAnsi(PAnsiChar(Source),PAnsiChar(Result));
  887. end;
  888.  
  889. {---------------------------------------------------------}
  890.  
  891. function  DTAsciiToAnsi
  892.           (
  893.           const Source : AnsiString
  894.           ): string;
  895.  var Buffer : TMiscBuffer;
  896.  begin
  897.   OemToChar(PAnsiChar(Source),Buffer);
  898.   Result := FromAPI(StrPas(Buffer));
  899.  end;
  900.  
  901. {---------------------------------------------------------}
  902.  
  903. function DTWideStringToAnsiString
  904.          (
  905.          const ws : WideString;
  906.          CodePage : Word
  907.          ): AnsiString;
  908. var l: integer;
  909. begin
  910.   if ws = ''
  911.    then Result := ''
  912.    else begin
  913.          l := WideCharToMultiByte(CodePage,
  914.                 WC_COMPOSITECHECK or WC_DISCARDNS
  915.                 or WC_SEPCHARS or WC_DEFAULTCHAR,
  916.                 @ws[1], - 1, nil, 0, nil, nil);
  917.          SetLength(Result, l - 1);
  918.          if l > 1
  919.           then WideCharToMultiByte(CodePage,
  920.                  WC_COMPOSITECHECK or WC_DISCARDNS
  921.                  or WC_SEPCHARS or WC_DEFAULTCHAR,
  922.                  @ws[1], - 1, @Result[1], l - 1, nil, nil);
  923.         end;
  924. end;
  925.  
  926. {---------------------------------------------------------}
  927.  
  928. function DTAnsiStringToWideString
  929.          (
  930.          const s  : AnsiString;
  931.          CodePage : Word
  932.          ): WideString;
  933. var
  934.   l: integer;
  935. begin
  936.   if s = ''
  937.    then Result := ''
  938.    else begin
  939.          l := MultiByteToWideChar(CodePage, MB_PRECOMPOSED,
  940.                          PAnsiChar(@s[1]), - 1, nil, 0);
  941.          SetLength(Result, l - 1);
  942.          if l > 1 then
  943.          MultiByteToWideChar(CodePage, MB_PRECOMPOSED,
  944.                          PAnsiChar(@s[1]),
  945.             - 1, PWideChar(@Result[1]), l - 1);
  946.         end;
  947. end;
  948.  
  949. {---------------------------------------------------------}
  950.  
  951. function DTAnsiStringToString(s:AnsiString): string;
  952.  begin
  953.   {$IFDEF FPC}
  954.    Result := AnsiToUTF8(s);
  955.   {$ELSE}
  956.   {$IFDEF UNICODE}
  957.    Result := DTAnsiStringToWideString(s,CP_ACP);
  958.   {$ELSE}
  959.    Result := s;
  960.   {$ENDIF UNICODE}
  961.   {$ENDIF FPC}
  962.  end;
  963.  
  964. {---------------------------------------------------------}
  965.  
  966. function DTWideStringToString(s:WideString): string;
  967.  begin
  968.   {$IFDEF FPC}
  969.    Result := s;
  970.   {$ELSE}
  971.   {$IFDEF UNICODE}
  972.    Result := s;
  973.   {$ELSE}
  974.    Result := DTWideStringToAnsiString(s,CP_ACP);
  975.   {$ENDIF UNICODE}
  976.   {$ENDIF FPC}
  977.  end;
  978.  
  979. {---------------------------------------------------------}
  980.  
  981. function DTStringToAnsiString(s:string): AnsiString;
  982.  begin
  983.   {$IFDEF FPC}
  984.    Result := UTF8ToAnsi(s);
  985.   {$ELSE}
  986.   {$IFDEF UNICODE}
  987.    Result := DTWideStringToAnsiString(s,CP_ACP);
  988.   {$ELSE}
  989.    Result := s;
  990.   {$ENDIF UNICODE}
  991.   {$ENDIF FPC}
  992.  end;
  993.  
  994. {---------------------------------------------------------}
  995.  
  996. function DTStringToWideString(s:string): WideString;
  997.  begin
  998.   {$IFDEF FPC}
  999.    Result := s;
  1000.   {$ELSE}
  1001.   {$IFDEF UNICODE}
  1002.    Result := s;
  1003.   {$ELSE}
  1004.    Result := DTAnsiStringToWideString(s,CP_ACP);
  1005.   {$ENDIF UNICODE}
  1006.   {$ENDIF FPC}
  1007.  end;
  1008.  
  1009. {---------------------------------------------------------}
  1010.  
  1011. function DTGetFileAge
  1012.          (
  1013.          const AFileName : string
  1014.          ): TDateTime;
  1015.  begin
  1016.   {$IFDEF UNICODE}
  1017.    FileAge(AFileName,Result);
  1018.   {$ELSE}
  1019.    Result := FileAge(AFileName);
  1020.   {$ENDIF UNICODE}
  1021.  end;
  1022.  
  1023. {---------------------------------------------------------}
  1024.  
  1025. function DTFileAge
  1026.          (
  1027.          const AFileName : string
  1028.          ): Integer;
  1029. begin
  1030.  if FileExists(AFileName)
  1031.   then Result:= DateTimeToFileDate(DTGetFileAge(AFileName))
  1032.   else Result:= -1;
  1033. end;
  1034.  
  1035. {---------------------------------------------------------}
  1036.  
  1037. Function  DTVersionToStr(const Version:Cardinal):string;
  1038.  begin
  1039.   if Version mod 100 = 0
  1040.    then Result := Format('%d.%.1d',[Version div 1000,
  1041.                                 (Version div 100) mod 10])
  1042.    else if Version mod 10 = 0
  1043.          then Result := Format('%d.%.2d',[Version div 1000,
  1044.                                 (Version div 10) mod 100])
  1045.          else Result := Format('%d.%.3d',[Version div 1000,
  1046.                                 (Version mod 1000)]);
  1047.  end;
  1048.  
  1049. {---------------------------------------------------------}
  1050.  
  1051. procedure DTGetFileVersInfos
  1052.           (
  1053.           const AFileName : string;
  1054.           var   Info      : TDTVersInfos
  1055.           );
  1056. (*  tagVS_FIXEDFILEINFO = packed record
  1057.     dwSignature: DWORD;        { e.g. $feef04bd }
  1058.     dwStrucVersion: DWORD;     { e.g. $00000042 = "0.42" }
  1059.     dwFileVersionMS: DWORD;    { e.g. $00030075 = "3.75" }
  1060.     dwFileVersionLS: DWORD;    { e.g. $00000031 = "0.31" }
  1061.     dwProductVersionMS: DWORD; { e.g. $00030010 = "3.10" }
  1062.     dwProductVersionLS: DWORD; { e.g. $00000031 = "0.31" }
  1063.     dwFileFlagsMask: DWORD;    { = $3F for version "0.42" }
  1064.     dwFileFlags: DWORD; { e.g. VFF_DEBUG | VFF_PRERELEASE }
  1065.     dwFileOS: DWORD;           { e.g. VOS_DOS_WINDOWS16 }
  1066.     dwFileType: DWORD;         { e.g. VFT_DRIVER }
  1067.     dwFileSubtype: DWORD;      { e.g. VFT2_DRV_KEYBOARD }
  1068.     dwFileDateMS: DWORD;       { e.g. 0 }
  1069.     dwFileDateLS: DWORD;       { e.g. 0 }
  1070.   end;*)
  1071. var
  1072.   FileName : string;
  1073.   FNBuf    : TFileBuffer;
  1074.   InfoSize, Wnd: DWORD;
  1075.   VerBuf   : TMiscBuffer;
  1076.   FI       : PVSFixedFileInfo;
  1077.   VerSize  : DWORD;
  1078.   function GetFlag(AMask:DWORD): Boolean;
  1079.    begin
  1080.     Result := ( FI^.dwFileFlags and AMask ) <> 0;
  1081.    end;
  1082. begin
  1083.  FillChar(Info,SizeOf(Info),0);
  1084.  with Info do
  1085.    begin
  1086.     if AFileName <> ''
  1087.        then FileName := AFileName
  1088.        else FileName := Application.ExeName;
  1089.     StrPCopy(@FNBuf,ToApi(FileName));
  1090.     InfoSize := GetFileVersionInfoSize(FNBuf,Wnd);
  1091.     if InfoSize <> 0 then
  1092.      begin
  1093.       try
  1094.        ZeroMemory(@VerBuf,InfoSize);
  1095.        if GetFileVersionInfo(FNBuf, Wnd,
  1096.                              InfoSize, @VerBuf)
  1097.         then
  1098.           if VerQueryValue(@VerBuf, '\',
  1099.                            Pointer(FI), VerSize)
  1100.            then
  1101.             with FI^ do
  1102.              begin
  1103.               Major        := dwFileVersionMS shr 16;
  1104.               Minor        := dwFileVersionMS and $FFFF;
  1105.               Release      := dwFileVersionLS shr 16;
  1106.               Build        := dwFileVersionLS and $FFFF;
  1107.               Debug        := GetFlag(VS_FF_DEBUG        );
  1108.               PreRelease   := GetFlag(VS_FF_PRERELEASE   );
  1109.               Patched      := GetFlag(VS_FF_PATCHED      );
  1110.               PrivateBuild := GetFlag(VS_FF_PRIVATEBUILD );
  1111.               InfoInferred := GetFlag(VS_FF_INFOINFERRED );
  1112.               SpecialBuild := GetFlag(VS_FF_SPECIALBUILD );
  1113.              end;
  1114.       finally
  1115.        Version    := Major * 1000  +  Minor;
  1116.        VersionStr := DTVersionToStr(Version);
  1117.      end;
  1118.    end;
  1119.   end;
  1120. end;
  1121.  
  1122. {---------------------------------------------------------}
  1123.  
  1124. procedure DTGetFileTimeInfos
  1125.           (
  1126.           const AFileName : string;
  1127.           var   Info      : TDTTimeInfos
  1128.           );
  1129. var Age : TDateTime; FileName : string;
  1130. begin
  1131.  FillChar(Info,SizeOf(Info),0);
  1132.  with Info do
  1133.   begin
  1134.    if AFileName <> ''
  1135.     then begin
  1136.           if not FileExists(AFileName) then Exit;
  1137.           FileName := AFileName
  1138.          end
  1139.     else FileName := Application.ExeName;
  1140.    {$IFDEF UNICODE} // Delphi 2009 +
  1141.    if FileAge(FileName,Age) then
  1142.     begin
  1143.      DecodeDate(Age,Year,Month,Day);
  1144.      DecodeTime(Age,Hour,Min,Sec,MSec);
  1145.     end;
  1146.    {$ELSE} // Lazarus 0.9.25 +, Delphi 2007 -
  1147.    Age := FileAge(FileName);
  1148.    DecodeDate(Age,Year,Month,Day);
  1149.    DecodeTime(Age,Hour,Min,Sec,MSec);
  1150.    {$ENDIF}
  1151.   end;
  1152. end;
  1153.  
  1154. {---------------------------------------------------------}
  1155.  
  1156. procedure DTGetFileVersTimeInfos
  1157.           (
  1158.           const AFileName : string;
  1159.           var   Info      : TDTVersTimeInfos
  1160.           );
  1161.  begin
  1162.   DTGetFileVersInfos(AFileName,Info.vers);
  1163.   DTGetFileTimeInfos(AFileName,Info.time);
  1164.  end;
  1165.  
  1166. {---------------------------------------------------------}
  1167.  
  1168. function  DTFormatVersTimeInfos
  1169.           (
  1170.           const AFormat : string;
  1171.           var   Info    : TDTVersTimeInfos
  1172.           ): string;
  1173. begin
  1174.  with Info,vers,time do
  1175.  Result := Format(AFormat,[VersionStr,Major,Minor,Build,
  1176.                            Release,Version,Year,Month,Day,
  1177.                            Hour,Min,Sec,MSec]);
  1178. end;
  1179.  
  1180. {---------------------------------------------------------}
  1181.  
  1182. Function  DTReadUserShellFolder
  1183.           (
  1184.           const path,folder : string
  1185.           ): string;
  1186. var TheType,TheBufferSize:Integer;
  1187.     TheKey:HKEY;
  1188.     TheBuffer : TFileBuffer;
  1189.     Res:Integer;
  1190.     PathPtr,FoldPtr:TMiscBuffer;
  1191. begin
  1192.  Result := '';
  1193.  StrPCopy(@PathPtr,ToApi(path));
  1194.  StrPCopy(@FoldPtr,ToApi(folder));
  1195.  if RegOpenKeyEx(HKEY_CURRENT_USER,PathPtr,0,
  1196.                  KEY_ALL_ACCESS,TheKey) = ERROR_SUCCESS
  1197.     then begin
  1198.           TheBufferSize := SizeOf(TheBuffer);
  1199.           Res:=RegQueryValueEx(TheKey,FoldPtr,nil,
  1200.                                @TheType,@TheBuffer,
  1201.                                @TheBufferSize);
  1202.           if Res=ERROR_SUCCESS
  1203.              then Result := FromApi(StrPas(TheBuffer));
  1204.           RegCloseKey(TheKey);
  1205.          end;
  1206. end;
  1207.  
  1208. {---------------------------------------------------------}
  1209.  
  1210. const
  1211. Base='Software\Microsoft\Windows\CurrentVersion\Explorer\';
  1212. UserShellFolders = Base + 'User Shell Folders';
  1213. ShellFolders     = Base + 'Shell Folders';
  1214.  
  1215. Function  DTGetShellFolder
  1216.           (
  1217.           const Folder: string
  1218.           ): string;
  1219. var ProvRes:string;
  1220. begin
  1221.  ProvRes := DTReadUserShellFolder(UserShellFolders,folder);
  1222.  if ProvRes = ''
  1223.   then ProvRes := DTReadUserShellFolder(ShellFolders,
  1224.                                         folder);
  1225.  Result:=DTFilterEnvVars(ProvRes);
  1226. end;
  1227.  
  1228. {---------------------------------------------------------}
  1229.  
  1230. {$IFDEF FPC}
  1231.  function GetEnvironmentVariable
  1232.          (lpName: PWideChar; lpBuffer: PWideChar;
  1233.           nSize: DWORD): DWORD; stdcall external
  1234.           kernel32 name 'GetEnvironmentVariableA';
  1235. {$ENDIF}
  1236.  
  1237. Function  DTGetEnvironmentVariable
  1238.           (
  1239.            EnvVar:string
  1240.           ): string;
  1241. var TheBuffer : TMiscBuffer;
  1242.     EnvVarBuf : TMiscBuffer;
  1243. begin
  1244.  StrPCopy(@EnvVarBuf,ToAPI(EnvVar));
  1245.  if GetEnvironmentVariable(@EnvVarBuf,
  1246.                        @TheBuffer,SizeOf(TheBuffer)) = 0
  1247.   then Result := ''
  1248.   else Result := FromAPI(StrPas(TheBuffer));
  1249. end;
  1250.  
  1251. {---------------------------------------------------------}
  1252.  
  1253. Function  DTFilterEnvVars
  1254.           (
  1255.            Path:string
  1256.           ): string;
  1257. var Buffer  : TMiscBuffer;
  1258.     PathBuf : TMiscBuffer;
  1259. begin
  1260.  StrPCopy(@PathBuf,ToAPI(Path));
  1261.  if ExpandEnvironmentStrings(@PathBuf,@Buffer,
  1262.                              SizeOf(Buffer)) = 0
  1263.   then Result := Path
  1264.   else Result := FromAPI(StrPas(Buffer));
  1265. end;
  1266.  
  1267. {---------------------------------------------------------}
  1268.  
  1269. Function  DTRegReadString
  1270.           (
  1271.           HRoot : HKEY;
  1272.           SSection, SKey, SDefValue : String
  1273.           ): String;
  1274. var
  1275.   QValue : TMiscBuffer;
  1276.   SKBuff : TMiscBuffer;
  1277.   DataSize: Integer;
  1278.   CurrentKey: HKEY;
  1279. begin
  1280.   StrPCopy(SKBuff,ToAPI(SKey));
  1281.   if RegOpenKeyEx(HRoot, @SKBuff, 0,
  1282.                KEY_QUERY_VALUE, CurrentKey) = ERROR_SUCCESS
  1283.   then begin
  1284.         Datasize := SizeOf(QValue) - 1;
  1285.         if RegQueryValueEx(CurrentKey, @SKBuff,
  1286.                            nil, nil, @QValue,
  1287.                            @DataSize) = ERROR_SUCCESS
  1288.            then Result := FromAPI(StrPas(QValue))
  1289.            else Result := SDefValue;
  1290.         RegCloseKey(CurrentKey);
  1291.        end
  1292.   else Result := SDefValue;
  1293. end;
  1294.  
  1295. {---------------------------------------------------------}
  1296.  
  1297. Procedure DTBrowse
  1298.           (
  1299.           AnURL : string
  1300.           );
  1301.  var Browser : String;P:Integer;
  1302.  begin
  1303.   Browser := DTRegReadString(HKEY_CLASSES_ROOT,
  1304.                       'http\shell\open\command','','');
  1305.   if Browser = '' then Exit;
  1306.   P := pos('%1',Browser);
  1307.   if P <= 0
  1308.    then Browser := Browser + ' ' + AnUrl
  1309.    // Some browser strings use '%1' to designate the url.
  1310.    // Certains navigateurs utilisent '%1' pour l'url.
  1311.    else begin
  1312.          Browser[P+1] := 's';
  1313.          Browser := Format(Browser,[AnUrl]);
  1314.         end;
  1315.   // I know, WinExec is deprecated. In the true life, I use
  1316.   // a function DTWinExec using CreateProcess.
  1317.   // Je sais, WinExec est déprécié. En réalité, je me sers
  1318.   // d'une fonction DTWinExec utilisant CreateProcess.
  1319.   WinExec(PAnsiChar(AnsiString(Browser)),SW_SHOW);
  1320.  end;
  1321.  
  1322. {---------------------------------------------------------}
  1323.  
  1324. var VarFolderPersonal:string='';
  1325.  
  1326. Function  DTFolderPersonal: string;
  1327. begin
  1328.  if VarFolderPersonal = ''
  1329.     then VarFolderPersonal
  1330.              := IncludeTrailingPathDelimiter
  1331.                        (DTGetShellFolder(shfold_Personal));
  1332.  Result := VarFolderPersonal;
  1333. end;
  1334.  
  1335. END.