我的公共函数单元（二）（Delphi）

{
  This unit was generated on Sun, 10 Dec 2006 09:45:52 +0000
  by the code snippets database at www.delphidabbler.com.
  Check the site for updates.

  The unit is freeware and may be freely distributed providing
  only that this comment is left in the code.
}

unit  DDSnippets ;

interface

uses
   Windows ,  SysUtils ,  ShellAPI ,  Classes ,  IniFiles ,  Graphics ,  UrlMon ,  Nb30 ,
   ShlObj ,  ActiveX ,  Registry ;

function  DateTimeToWinFileTime ( DT :  TDateTime ):  Windows . TFileTime ;
{Converts Delphi TDateTime to Windows FILETIME. Raises exception if date time
is not valid or can't be converted.}

function  GMTToLocalTime ( GMTTime :  TDateTime ):  TDateTime ;
{Converts Delphi TDateTime in GMT local time. Raises exception if date time is
not valid or can't be converted.}

function  WinFileTimeToDateTime ( FT :  Windows . TFileTime ):  TDateTime ;
{Converts Windows FILETIME to Delphi TDateTime. Raises exception if file time
is valid or can't be converted.}

function  WinFileTimeToDOSFileTime ( FT :  Windows . TFileTime ):  Integer ;
{Converts a Windows FILETIME to a DOS file time. Raises exception if file time
is not a valid value.}

function  WinFileTimeToStr ( FT :  Windows . TFileTime ):  string ;
{Converts a Windows FILETIME structure to a string. Raises exception if file
time is not a valid value.}

function  DriveDisplayName ( const  Drive :  string ):  string ;
{Returns the display name for the drive with the given root path.}

procedure  DriveDisplayNames ( const  List :  Classes . TStrings );
{Gets list of display names for all the system's drives and stores in a given
string list.}

function  DriveRootPath ( const  DriveNum :  Byte ):  string ;
{Returns root drive path for drive with given number.}

function  DriveTypeFromPath ( const  Path :  string ):  Integer ;
{Returns type of drive that contains the given (full) path.}

function  HardDiskSerial ( const  Drive :  string ):  Windows . DWORD ;
{Returns the serial number of the hard disk with the given root path or 0 if
the disk is not a hard drive or has no serial number.}

function  IsValidDrive ( const  Drive :  string ):  Boolean ;
{Returns true if the given drive path represents a valid drive and false
otherwise.}

function  IsValidDriveNum ( const  DriveNum :  Byte ):  Boolean ;
{Returns true if the drive specified by the given number is valid and false
otherwise.}

procedure  ListDrives ( const  List :  Classes . TStrings );
{Gets list of the system's drive root paths and stores in a given string list}

function  FileToString ( const  FileName :  string ):  string ;
{Stores content of a file in an ANSI string.}

function  IsUnicodeFile ( const  FileName :  string ):  Boolean ;
{Checks if a file contains unicode text and returns true if so and false if
not.}

function  IsUnicodeStream ( const  Stm :  Classes . TStream ):  Boolean ;
{Checks if a stream contains unicode text at the current position. Returns
true if stream contains unicode and false otherwise.}

function  StreamToString ( const  Stm :  Classes . TStream ):  string ;
{Reads content of a stream into an ansi string. Stream is read from current
positions.}

procedure  StringToFile ( const  Str ,  FileName :  string );
{Writes an ansi string to a text file.}

procedure  StringToStream ( const  Str :  string ;  const  Stm :  Classes . TStream );
{Writes an ansi string into a stream. The string is written at the current
stream position.}

function  UnicodeFileToWideString ( const  FileName :  string ):  WideString ;
{Reads a file into a wide string an returns it. The routine can handle unicode
files or ansi text files. Ansi files are converted to wide strings.}

function  UnicodeStreamToWideString ( const  Stm :  Classes . TStream ):  WideString ;
{Reads from a stream into a wide string an returns the string. The routine can
handle unicode or ansi content on the stream. If the text is unicode the word
at the current stream position must be a unicode marker word. Ansi files are
converted to wide strings.}

procedure  WideStringToUnicodeFile ( const  Str :  WideString ;
   const  FileName :  string );
{Writes a wide string to a unicode text file. The text file begins with a
marker to indicate it is unicode.}

procedure  WideStringToUnicodeStream ( const  Str :  WideString ;
   const  Stm :  Classes . TStream );
{Writes a wide string to a stream in unicode format. The output begins with a
marker to indicate it is unicode.}

procedure  CopyFile ( const  Source ,  Dest :  string );
{Copies Source file to Dest, preserving modification date.}

procedure  CreateURLShortcut ( const  ShortcutFile ,  URL :  string );
{Creates a URL shortcut file with the given name for the given URL,
overwriting any existing file. An exception is raised if file can't be
created.}

function  DeleteFiles ( const  Dir ,  Wildcard :  string ):  Integer ;
{Deletes all files in the directory Dir that match the given wildcard and
returns the number of files deleted. If Wildcard is '' then all files are
deleted. Sub-directories of Dir are not deleted.}

function  DeleteFileWithUndo ( const  FileName :  string ):  Boolean ;
{Deletes given file and sends it to recycle bin. Returns true if file deleted
successfully.}

function  DirToPath ( const  Dir :  string ):  string ;
{Returns the given directory with a trailing backslash. If the directory
already ends in backslash it is returned unchanged.}

function  DOSToUnixPath ( const  PathName :  string ):  string ;
{Converts a DOS path to a Unix path and returns it.}

procedure  EnsureFolders ( Path :  string );
{Ensures that the given folder and all folders on its path exist, and creates
them if they do not. Uses recursion.}

function  GetFileDate ( const  FName :  string ):  Integer ;
{Returns modification date of given file encoded as integer.}

function  GetFixedFileVerInfo ( const  FileName :  string ;
   var  FFI :  Windows . TVSFixedFileInfo ):  Boolean ;
{Extracts fixed version information from a file. If file contains version
information it is returned via FFI parameter and function returns true,
otherwise false is returned and FFI is undefined.}

function  HasVerInfo ( const  FileName :  string ):  Boolean ;
{Returns true if the given file contains version information and false if
not.}

function  IsDirectory ( const  DirName :  string ):  Boolean ;
{Returns true if given name is a valid directory and false otherwise. DirName
can be any file system name (with or without trailing path delimiter).}

function  IsURLShortcut ( const  ShortcutFile :  string ):  Boolean ;
{Returns true if the given file is a URL shortcut file and false if not.}

function  ListFiles ( const  Dir ,  Wildcard :  string ;
   const  List :  Classes . TStrings ):  Boolean ;
{Gets a list of the files and sub-directories of the given directory that
match the given wild card. The files are appended to the given string list.
Returns true if Dir is a valid directory and False if not. If Wildcard is not
specified, *.* is assumed.}

function  LongToShortFilePath ( const  LongName :  string ):  string ;
{Converts the given long file name to the equivalent shortened DOS style 8.3
path.}

function  PathToDir ( const  Path :  string ):  string ;
{Returns the given directory with any single trailing backslash removed. If
the directory does not end in a backslash it is returned unchanged.}

procedure  SetFileDate ( const  FName :  string ;  const  ADate :  Integer );
{Sets modification date of given file to given integer coded value.}

function  ShortToLongFilePath ( const  FilePath :  string ):  string ;
{Converts whole of given DOS style 8.3 path to long file path and returns it.
If path can't be converted then '' is returned.}

function  TempFileName ( const  Stub :  string ;  const  Create :  Boolean ):  string ;
{Returns a unique temporary file name in temporary folder. File name includes
first three characters of Stub followed by hexadecimal characters. If Create
is true file is created. Returns empty string on failure.}

function  Touch ( const  FileName :  string ):  Boolean ;
{Sets modification date of given file to current date and time. Returns true
if date set successfully or false on error.}

function  URLFromShortcut ( const  Shortcut :  string ):  string ;
{Returns the URL referenced by the given URL shortcut file, or the empty
string if the given file is not a shortcut file.}

function  ColorToRGBTriple ( const  C :  Graphics . TColor ):  Windows . TRGBTriple ;
{Converts a Delphi TColor value into an RGB triple value.}

procedure  DrawTextOutline ( const  Canvas :  Graphics . TCanvas ;  const  X ,  Y :  Integer ;
   const  Text :  string );
{Draws specified text in outline on a canvas. The top left corner of the text
is specified by X and Y parameters. Canvas' current brush and pen colours are
used to fill and outline the text respectively. If the canvas' current font is
not a vector font nothing is displayed.}

procedure  MakeGreyScale ( const  SrcBmp :  Graphics . TBitmap ;
   const  Advanced :  Boolean );
{Converts a colour bitmap into a 24bit greyscale bitmap. Setting the Advanced
flag to true uses a more advanced algorithm for the conversion. When the flag
is false red, blue and green values are simply averaged. The provided colour
bitmap is overwritten by the greyscale bitmap.}

function  RGBTripleToColor ( const  C :  Windows . TRGBTriple ):  Graphics . TColor ;
{Converts an RGB triple value into a Delphi TColor value.}

function  BrowseURL ( const  URL :  string ):  Boolean ;
{Activates default browser or email client for given URL. Returns true if
browser/email client is uccessfully launched and false if not. Raises
exception if URL doesn't conform to a known valid protocol.}

function  ColorToHTML ( const  Color :  Graphics . TColor ):  string ;
{Converts a Delphi TColor value into a string suitable for use in HTML or CSS
code. Any system colors (like clBtnFace) are mapped to the actual colour
according to the current Windows settings.}

function  DownloadURLToFile ( const  URL ,  FileName :  string ):  Boolean ;
{Downloads file at URL and stores in given file. Returns true if download
succeeds and false on failure. A connection to the internet must be open for
download to succeed.}

function  IsValidURLProtocol ( const  URL :  string ):  Boolean ;
{Checks if the given URL is valid per RFC1738. Returns true is valid and false
if not.}

function  MakeSafeHTMLText ( TheText :  string ):  string ;
{Replaces any characters in the given text that are HTML-compatible with
suitable escaped versions and returns modified string.}

function  URLDecode ( const  S :  string ):  string ;
{Decodes the given encoded URL or URL query string. Raises exception if the
encoded URL is badly formed.}

function  URLEncode ( const  S :  string ;  const  InQueryString :  Boolean ):  string ;
{Encodes the given string, making it suitable for use in a URL. The function
can encode strings for use in the main part of a URL (where spaces are
encoded as '%20') or in URL query strings (where spaces are encoded as '+'
characters). Set InQueryString to true to encode for a query string.}

function  CompressWhiteSpace ( const  S :  string ):  string ;
{Returns a copy of given string with all white space characters replaced by
space characters and all sequences of white space replaced by a single space
character.}

function  CountDelims ( const  S ,  Delims :  string ):  Integer ;
{Returns count of all occurences of any of the given delimiter characters in
the string S.}

function  ExplodeStr ( S :  string ;  const  Delim :  Char ;  const  List :  Classes . TStrings ;
   const  AllowEmpty :  Boolean  =  True ):  Integer ;
{Splits the string S into a list of strings, separated by Delim, and returns
the number of strings in the list. If AllowEmpty is true then any empty
strings are added to the list, while they are ignored if AllowEmpty is
false.}

function  IsHexStr ( const  S :  string ):  Boolean ;
{Returns true if string S contains only valid hex digits, false otherwise.}

function  JoinStr ( const  SL :  Classes . TStrings ;  const  Delim :  string ;
   const  AllowEmpty :  Boolean  =  True ):  string ;
{Joins all strings in given string list together into single string separated
by given delimiter. If AllowEmpty is true then any empty strings are included
in output string, but are ignored if false.}

procedure  MultiSzToStrings ( const  MultiSz :  PChar ;
   const  Strings :  Classes . TStrings );
{Splits out individual strings from given 'MultiSz' strings buffer and adds
each string to the given string list. A MultiSz string is a sequence of #0
delimited strings terminated by an extra #0 character. Does nothing if string
list or MultiSz buffer are nil.}

function  ParseDelims ( const  TextLine :  string ;  var  StartPos :  Integer ;
   const  Delims :  string ):  string ;
{Returns the sub-string of TextLine that begins at StartPos and is terminated
by one of the delimiting characters Delims or the end of the string. StartPos
is updated to index of character after delimiter. Returns '' if there is no
sub-string after StartPos.}

function  SplitStr ( const  S :  string ;  Delim :  Char ;  out  S1 ,  S2 :  string ):  Boolean ;
{Splits the string S at the first occurence of delimiter character Delim and
sets S1 to the sub-string before Delim and S2 to substring following Delim.
If Delim is found in string True is returned, while if Delim is not in string
False is returned, S1 is set to S and S2 is set to ''.}

function  StringsToMutliSz ( const  Strings :  Classes . TStrings ;
   const  MultiSz :  PChar ;  const  BufSize :  Integer ):  Integer ;
{Copies the strings from a given string list and stores in a provided MulitiSz
buffer of a given size. The strings in the buffer are separated by #0 and the
buffer is terminated by an additional #0. Returns 0 on success or required
buffer size if MultiSz is nil or buffer size is too small. To get required
buffer size call function with MultiSz=nil and BufSize=0.}

function  GetMacAddress :  string ;
{Returns MAC address of first ethernet adapter on computer.}

function  IsLockKeyOn ( const  KeyCode :  Integer ):  Boolean ;
{Detects if a given lock key is on and returns true if so. An exception is
raised if KeyCode is not a valid lock key code. Valid lock key codes are
VK_CAPITAL, VK_NUMLOCK and VK_SCROLL.}

procedure  SetLockKeyState ( KeyCode :  Integer ;  IsOn :  Boolean );
{Sets the given lock key state to given value. Passing True switches lock key
on and passing False switches it off. An exception is raised if KeyCode is
not a valid lock key code. Valid lock key codes are VK_CAPITAL, VK_NUMLOCK
and VK_SCROLL.}

procedure  AddToRecentDocs ( const  FileName :  string );
{Adds given file to Recent Documents folder that appears on the Start menu.}

procedure  ClearRecentDocs ;
{Clears the Recent Documents folder so that no recent documents appear on
Start menu.}

function  CreateShellLink ( const  LinkFileName ,  AssocFileName ,  Desc ,  WorkDir ,
   Args ,  IconFileName :  string ;  const  IconIdx :  Integer ):  Boolean ;
{Creates a shell link named LinkFileName that is a shortcut to file
AssocFileName with descriprion Desc. The shortcut activates its file in the
given working directory and passes the given command line Args to
AssocFileName. If an icon file and index offset are provided the specified
icon is used for the shortcut. True is returned on success and false on
error.}

function  EmptyRecycleBin :  Boolean ;
{Empties the recycle bin. Returns returns true if bin is emptied and false if
the function fails.}

function  ExecAndWait ( const  CommandLine :  string ):  Boolean ;
{Executes the given command line and waits for the program started by the
command line to exit. Returns true if the program returns a zero exit code
and false if the program doesn't start or returns a non-zero error code.}

function  ExecAssociatedApp ( const  FileName :  string ):  Boolean ;
{Executes the application associated with the given file name. Returns true if
application is started successfully and false if not.}

function  ExploreFile ( const  Filename :  string ):  Boolean ;
{Starts Windows Explorer to explore given file. Returns true if file is valid
and can be explored, or false otherwise.}

function  ExploreFolder ( const  Folder :  string ):  Boolean ;
{Starts Windows Explorer to explore given folder. Returns true if folder is
valid and can be explored, or false otherwise.}

function  FileFromShellLink ( const  LinkFileName :  string ):  string ;
{Returns the fully specified name of the file associated with the given shell
link (shortcut) file. Returns '' if the file is not a shell link or if it is
a shortcut to a non-file shell object.}

function  FindAssociatedApp ( const  Doc :  string ):  string ;
{Returns the fully specified path of the program associated with the given
document file name. Requires ShellAPI. Returns empty string if no such
associated application.}

procedure  FreePIDL ( PIDL :  ShlObj . PItemIDList );
{Uses to shell allocator to free the memory used by a given PIDL.}

function  IsShellLink ( const  LinkFileName :  string ):  Boolean ;
{Checks if the given file is a shell link.}

function  IsSpecialFolderSupported ( CSIDL :  Integer ):  Boolean ;
{Returns true if the given special folder specified by a CSIDL is supported on
the system and false if not.}

function  LoadShellLink ( const  LinkFileName :  string ):  ShlObj . IShellLink ;
{Loads a shell link file into a shell link object and returns the IShellLink
interface of the object. If the given file is not a shell link nil is
returned. The returned object can be used to access information about the
shell link.}

function  OpenFolder ( const  Folder :  string ):  Boolean ;
{Opens given folder in Windows Explorer. Returns true if folder is valid and
can be opened, or false otherwise.}

function  PIDLToFolderPath ( PIDL :  ShlObj . PItemIDList ):  string ;
{Returns the full path to a file system folder from a PIDL or '' if the PIDL
refers to a virtual folder.}

function  ShowFindFilesDlg ( const  Folder :  string ):  Boolean ;
{Displays the Windows find files dialog box ready for searching the given
folder. Returns true if dialog is shown and false if can't be shown (e.g. if
given folder is not valid).}

function  SpecialFolderPath ( CSIDL :  Integer ):  string ;
{Returns the full path to a special file system folder specified by a CSIDL
constant FolderID or '' if the special folder is virtual or CSIDL is not
supported.}

function  TaskAllocWideString ( const  S :  string ):  Windows . PWChar ;
{Converts a given ANSI string to a wide string and stores in a buffer
allocated by the Shell's task allocator. If the buffer needs to be freed
IMalloc.Free should be used to do this.}

function  TaskbarHandle :  Windows . THandle ;
{Returns the window handle of the Windows task bar.}

function  CommonFilesFolder :  string ;
{Returns directory used for common files.}

function  GetCurrentVersionRegStr ( const  ValName :  string ):  string ;
{Gets given string value from given subkey of Windows current version registry
key.}

function  GetRegistryString ( const  RootKey :  Windows . HKEY ;
   const  SubKey ,  Name :  string ):  string ;
{Gets a string value from the registry from the given root and sub key.
Converts integers to strings and raises exception for binary and unknown
value types. Returns '' if the sub key or value name are not known.}

function  IsIntResource ( const  ResID :  PChar ):  Boolean ;
{Returns true if the given resource ID is integer value or false if the ID is
a pointer to a zero terminated string.}

function  IsMediaCenterOS :  Boolean ;
{Returns true if the operating system is a Windows Media Center edition or
false if not.}

function  IsTabletOS :  Boolean ;
{Returns true if the operating system is a Windows Tablet edition or false if
not.}

function  IsWin9x :  Boolean ;
{Returns true if the operating system is on the Windows 9x platform (including
Windows 95, 98 and Me) and false if not.}

function  IsWinNT :  Boolean ;
{Returns true if the operating system is Windows NT (including 2000 and XP)
and false if not.}

function  IsWow64 :  Boolean ;
{Returns true if the current process is executing as a 32 bit process under
WOW64 on 64 bit Windows.}

function  ProgramFilesFolder :  string ;
{Returns directory used for program files.}

function  SystemFolder :  string ;
{Returns path to Windows system folder.}

function  TempFolder :  string ;
{Returns path to Windows temporary folder.}

function  WindowsFolder :  string ;
{Returns path to Windows folder.}

function  WindowsProductID :  string ;
{Returns the Windows product ID.}

implementation

{ Implementation of public and private routines }

function  DateTimeToWinFileTime ( DT :  TDateTime ):  Windows . TFileTime ;
{Converts Delphi TDateTime to Windows FILETIME. Raises exception if date time
is not valid or can't be converted.}
var
   ST :  Windows . TSystemTime ;
begin
   SysUtils . DateTimeToSystemTime ( DT ,  ST );
   SysUtils . Win32Check ( Windows . SystemTimeToFileTime ( ST ,  Result ));
end ;

function  GMTToLocalTime ( GMTTime :  TDateTime ):  TDateTime ;
{Converts Delphi TDateTime in GMT local time. Raises exception if date time is
not valid or can't be converted.}
var
   GMTST :  Windows . TSystemTime ;
   LocalST :  Windows . TSystemTime ;
begin
   SysUtils . DateTimeToSystemTime ( GMTTime ,  GMTST );
   SysUtils . Win32Check (
     Windows . SystemTimeToTzSpecificLocalTime (
     nil ,  GMTST ,  LocalST
     )
     );
   Result  :=  SysUtils . SystemTimeToDateTime ( LocalST );
end ;

function  WinFileTimeToDateTime ( FT :  Windows . TFileTime ):  TDateTime ;
{Converts Windows FILETIME to Delphi TDateTime. Raises exception if file time
is valid or can't be converted.}
var
   SysTime :  Windows . TSystemTime ;          // stores date/time in system time format
begin
   // Convert file time to system time, raising exception on error
   SysUtils . Win32Check ( Windows . FileTimeToSystemTime ( FT ,  SysTime ));
   // Convert system time to Delphi date time, raising excpetion on error
   Result  :=  SysUtils . SystemTimeToDateTime ( SysTime );
end ;

function  WinFileTimeToDOSFileTime ( FT :  Windows . TFileTime ):  Integer ;
{Converts a Windows FILETIME to a DOS file time. Raises exception if file time
is not a valid value.}
begin
   SysUtils . Win32Check (
     Windows . FileTimeToDosDateTime (
     FT ,  SysUtils . LongRec ( Result ). Hi ,  SysUtils . LongRec ( Result ). Lo
     )
     );
end ;

function  WinFileTimeToStr ( FT :  Windows . TFileTime ):  string ;
{Converts a Windows FILETIME structure to a string. Raises exception if file
time is not a valid value.}
begin
   Result  :=  SysUtils . DateTimeToStr ( WinFileTimeToDateTime ( FT ));
end ;

function  DriveDisplayName ( const  Drive :  string ):  string ;
{Returns the display name for the drive with the given root path.}
var
   FI :  ShellAPI . TSHFileInfo ;              // info about drive
begin
   if  ShellAPI . SHGetFileInfo (
     PChar ( Drive ),
     0 ,
     FI ,
     SizeOf ( FI ),
     ShellAPI . SHGFI_DISPLAYNAME
     )  =  0  then
     SysUtils . RaiseLastWin32Error ;
   Result  :=  FI . szDisplayName ;
end ;

procedure  DriveDisplayNames ( const  List :  Classes . TStrings );
{Gets list of display names for all the system's drives and stores in a given
string list.}
var
   Drives :  Classes . TStringList ;           // list of drives
   Idx :  Integer ;                          // loops thru drives
begin
   // Get list of drives
   Drives  :=  Classes . TStringList . Create ;
   try
     ListDrives ( Drives );
     // Loop thru drive list getting drive info
     for  Idx  :=  0  to  Pred ( Drives . Count )  do
       List . Add ( DriveDisplayName ( Drives [ Idx ]));
   finally
     Drives . Free ;
   end ;
end ;

function  DriveRootPath ( const  DriveNum :  Byte ):  string ;
{Returns root drive path for drive with given number.}
begin
   if  DriveNum  in  [ 0..25 ]  then
     Result  :=  Char ( DriveNum  +  Ord ( 'A' ))  +  ':/'
   else
     Result  :=  '' ;
end ;

function  DriveTypeFromPath ( const  Path :  string ):  Integer ;
{Returns type of drive that contains the given (full) path.}
var
   Drive :  string ;                         // the drive name
begin
   Drive  :=  SysUtils . ExtractFileDrive ( Path )  +  '/' ;
   Result  :=  Integer ( Windows . GetDriveType ( PChar ( Drive )));
end ;

function  HardDiskSerial ( const  Drive :  string ):  Windows . DWORD ;
{Returns the serial number of the hard disk with the given root path or 0 if
the disk is not a hard drive or has no serial number.}
var
   Unused :  Windows . DWORD ;                 // unused parameters
   PrevErrorMode :  Windows . UINT ;           // stores Windows error mode
begin
   // Inhibit system dialog appearing on error
   PrevErrorMode  :=  Windows . SetErrorMode (
     Windows . SEM_FAILCRITICALERRORS
     );
   try
     Result  :=  0 ;
     Windows . GetVolumeInformation (
       PChar ( Drive ),  nil ,  0 ,  @ Result ,  Unused ,  Unused ,  nil ,  0
       );
   finally
     // Restore old error mode
     Windows . SetErrorMode ( PrevErrorMode );
   end ;
end ;

function  IsValidDrive ( const  Drive :  string ):  Boolean ;
{Returns true if the given drive path represents a valid drive and false
otherwise.}
begin
   Result  :=  DriveTypeFromPath ( Drive )  <>  1 ;
end ;

function  IsValidDriveNum ( const  DriveNum :  Byte ):  Boolean ;
{Returns true if the drive specified by the given number is valid and false
otherwise.}
begin
   if  DriveNum  in  [ 0..25 ]  then
     Result  :=  Windows . GetLogicalDrives  and  ( 1  shl  DriveNum )  <>  0
   else
     Result  :=  False ;
end ;

procedure  ListDrives ( const  List :  Classes . TStrings );
{Gets list of the system's drive root paths and stores in a given string list}
var
   Drives :  PChar ;                         // buffer for list of drives
   BufSize :  Integer ;                      // size of drive buffer
begin
   // Get buffer size and allocate it
   BufSize  :=  Windows . GetLogicalDriveStrings ( 0 ,  nil );
   GetMem ( Drives ,  BufSize );
   try
     // Get #0 delimited drives list and convert to string list
     if  Windows . GetLogicalDriveStrings ( BufSize ,  Drives )  =  0  then
       SysUtils . RaiseLastWin32Error ;
     MultiSzToStrings ( Drives ,  List );
   finally
     FreeMem ( Drives );
   end ;
end ;

function  FileToString ( const  FileName :  string ):  string ;
{Stores content of a file in an ANSI string.}
var
   FS :  Classes . TFileStream ;               // stream used to read file
begin
   // Open stream to file and copy stream to string
   FS  :=  Classes . TFileStream . Create (
     FileName ,  SysUtils . fmOpenRead  or  SysUtils . fmShareDenyNone
     );
   try
     Result  :=  StreamToString ( FS );
   finally
     FS . Free ;
   end ;
end ;

function  IsUnicodeFile ( const  FileName :  string ):  Boolean ;
{Checks if a file contains unicode text and returns true if so and false if
not.}
var
   FS :  Classes . TFileStream ;               // stream onto file being tested
begin
   // Open stream to file and examine stream for unicode marker
   FS  :=  Classes . TFileStream . Create (
     FileName ,  SysUtils . fmOpenRead  or  SysUtils . fmShareDenyNone
     );
   try
     Result  :=  IsUnicodeStream ( FS );
   finally
     FS . Free ;
   end ;
end ;

function  IsUnicodeStream ( const  Stm :  Classes . TStream ):  Boolean ;
{Checks if a stream contains unicode text at the current position. Returns
true if stream contains unicode and false otherwise.}
var
   StmPos :  LongInt ;                       // current position in stream
   UnicodeMarker :  Word ;                   // marker that indicates a unicode stream
begin
   // Record current location in stream
   StmPos  :=  Stm . Position ;
   // Check if stream large enough to contain unicode marker
   if  StmPos  <=  Stm . Size  -  SizeOf ( Word )  then
   begin
     // Read first word and check if it is the unicode marker
     Stm . ReadBuffer ( UnicodeMarker ,  SizeOf ( UnicodeMarker ));
     Result  :=  ( UnicodeMarker  =  $FEFF );
     // Restore stream positions
     Stm . Position  :=  StmPos ;
   end
   else
     // Stream too small: can't be unicode
     Result  :=  False ;
end ;

function  StreamToString ( const  Stm :  Classes . TStream ):  string ;
{Reads content of a stream into an ansi string. Stream is read from current
positions.}
var
   SS :  Classes . TStringStream ;             // used to copy stream to string
begin
   SS  :=  Classes . TStringStream . Create ( '' );
   try
     // Copy given stream to string stream and return value
     SS . CopyFrom ( Stm ,  0 );
     Result  :=  SS . DataString ;
   finally
     SS . Free ;
   end ;
end ;

procedure  StringToFile ( const  Str ,  FileName :  string );
{Writes an ansi string to a text file.}
var
   FS :  Classes . TFileStream ;               // stream used to write file
begin
   // Create stream onto file and write to it
   FS  :=  Classes . TFileStream . Create ( FileName ,  Classes . fmCreate );
   try
     StringToStream ( Str ,  FS );
   finally
     FS . Free ;
   end ;
end ;

procedure  StringToStream ( const  Str :  string ;  const  Stm :  Classes . TStream );
{Writes an ansi string into a stream. The string is written at the current
stream position.}
var
   SS :  Classes . TStringStream ;             // used to copy string to stream
begin
   // Create stream onto string and copy it to given stream
   SS  :=  Classes . TStringStream . Create ( Str );
   try
     Stm . CopyFrom ( SS ,  Length ( Str ));
   finally
     SS . Free ;
   end ;
end ;

function  UnicodeFileToWideString ( const  FileName :  string ):  WideString ;
{Reads a file into a wide string an returns it. The routine can handle unicode
files or ansi text files. Ansi files are converted to wide strings.}
var
   FS :  Classes . TFileStream ;               // Stream used to read file
begin
   // Open stream onto file and read unicode from it
   FS  :=  Classes . TFileStream . Create (
     FileName ,  SysUtils . fmOpenRead  or  SysUtils . fmShareDenyNone );
   try
     Result  :=  UnicodeStreamToWideString ( FS );
   finally
     FS . Free ;
   end ;
end ;

function  UnicodeStreamToWideString ( const  Stm :  Classes . TStream ):  WideString ;
{Reads from a stream into a wide string an returns the string. The routine can
handle unicode or ansi content on the stream. If the text is unicode the word
at the current stream position must be a unicode marker word. Ansi files are
converted to wide strings.}
var
   DataSize :  LongInt ;                     // size of the unicode in bytes
begin
   if  IsUnicodeStream ( Stm )  then
   begin
     // Data on stream is unicode
     // set size of unicode (excluding marker word)
     DataSize  :=  Stm . Size  -  Stm . Position  -  SizeOf ( Word );
     // size must be multiple of size of unicode char
     if  DataSize  mod  SizeOf ( WideChar )  <>  0  then
       Classes . EStreamError . CreateFmt (
         'Remaining data in stream must be a mulitple of %d bytes' ,
         [ SizeOf ( WideChar )]
         );
     // Skip over unicode marker
     Stm . Position  :=  Stm . Position  +  SizeOf ( Word );
     // Read stream into result
     SetLength ( Result ,  DataSize  div  SizeOf ( WideChar ));
     Stm . ReadBuffer ( Windows . PByte ( PWideChar ( Result ))^,  DataSize );
   end
   else
     // Data on stream is not unicode: read it with ansi reader
     // result of StreamToString is automatically converted to WideString
     Result  :=  StreamToString ( Stm );
end ;

procedure  WideStringToUnicodeFile ( const  Str :  WideString ;
   const  FileName :  string );
{Writes a wide string to a unicode text file. The text file begins with a
marker to indicate it is unicode.}
var
   FS :  Classes . TFileStream ;               // Stream onto file being created
begin
   // Open stream onto file and write unicode to it
   FS  :=  Classes . TFileStream . Create ( FileName ,  Classes . fmCreate );
   try
     WideStringToUnicodeStream ( Str ,  FS );
   finally
     FS . Free ;
   end ;
end ;

procedure  WideStringToUnicodeStream ( const  Str :  WideString ;
   const  Stm :  Classes . TStream );
{Writes a wide string to a stream in unicode format. The output begins with a
marker to indicate it is unicode.}
var
   UnicodeMarker :  Word ;                   // Marker that begins unicode
begin
   // Write out unicode marker
   UnicodeMarker  :=  $FEFF ;
   Stm . WriteBuffer ( UnicodeMarker ,  SizeOf ( Word ));
   // Write unicode text
   Stm . WriteBuffer (
     Windows . PByte ( PWideChar ( Str ))^,  SizeOf ( WideChar )  *  Length ( Str )
     );
end ;

procedure  CopyFile ( const  Source ,  Dest :  string );
{Copies Source file to Dest, preserving modification date.}
var
   SourceStream ,  DestStream :  Classes . TFileStream ;  // source and dest file streams
begin
   DestStream  :=  nil ;
   // Open source and dest file streams
   SourceStream  :=  Classes . TFileStream . Create (
     Source ,  SysUtils . fmOpenRead  or  SysUtils . fmShareDenyWrite
     );
   try
     DestStream  :=  Classes . TFileStream . Create (
       Dest ,  Classes . fmCreate  or  SysUtils . fmShareExclusive
       );
     // Copy file from source to dest
     DestStream . CopyFrom ( SourceStream ,  SourceStream . Size );
     // Set dest file's modification date to same as source file
     SysUtils . FileSetDate (
       DestStream . Handle ,  SysUtils . FileGetDate ( SourceStream . Handle )
       );
   finally
     // Close files
     DestStream . Free ;
     SourceStream . Free ;
   end ;
end ;

procedure  CreateURLShortcut ( const  ShortcutFile ,  URL :  string );
{Creates a URL shortcut file with the given name for the given URL,
overwriting any existing file. An exception is raised if file can't be
created.}
var
   F :  TextFile ;                           // text file
begin
{$I+}                                    // ensure file i/o raises exception on error
   // Open new file for writing (overwrites any existing file)
   AssignFile ( F ,  ShortcutFile );
   Rewrite ( F );
   try
     // Write file contents: this is simplest basic format of shortcut file
     WriteLn ( F ,  '[InternetShortcut]' );
     WriteLn ( F ,  'URL=' ,  URL );
   finally
     // Close file
     CloseFile ( F );
   end ;
end ;

function  DeleteFiles ( const  Dir ,  Wildcard :  string ):  Integer ;
{Deletes all files in the directory Dir that match the given wildcard and
returns the number of files deleted. If Wildcard is '' then all files are
deleted. Sub-directories of Dir are not deleted.}
var
   Files :  Classes . TStringList ;            // stores files to be deleted
   I :  Integer ;                            // loops thru files in folder
   AFile :  string ;                         // a file to be deleted
   Path :  string ;                          // path to directory
   Attr :  Integer ;                         // attributes of a file
begin
   Result  :=  0 ;
   // Create list to stores files to be deleted
   Files  :=  Classes . TStringList . Create ;
   try
     // List files per file spec into string list
     if  not  ListFiles ( Dir ,  Wildcard ,  Files )  then
       Exit ;
     // Get path of directory containing files
     Path  :=  DirToPath ( Dir );
     // Loop through all files
     for  I  :=  0  to  Pred ( Files . Count )  do
     begin
       // Get name and attributes of file to be deleted
       AFile  :=  Path  +  Files [ I ];
       Attr  :=  SysUtils . FileGetAttr ( AFile );
       // Delete file if it is not a directory
       if  ( Attr  and  SysUtils . faDirectory  =  0 )  then
       begin
         if  SysUtils . DeleteFile ( AFile )  then
           // File deleted: count it
           Inc ( Result );
       end ;
     end ;
   finally
     // Tidy up
     Files . Free ;
   end ;
end ;

function  DeleteFileWithUndo ( const  FileName :  string ):  Boolean ;
{Deletes given file and sends it to recycle bin. Returns true if file deleted
successfully.}
var
   FOS :  ShellAPI . TSHFileOpStruct ;         // contains info about required file operation
begin
   // Set up structure that determines file operation
   FillChar ( FOS ,  SizeOf ( FOS ),  0 );
   with  FOS  do
   begin
     wFunc  :=  ShellAPI . FO_DELETE ;         // we're deleting
     pFrom  :=  PChar ( FileName  +  #0 );       // this file (#0#0 terminated)
     fFlags  :=  ShellAPI . FOF_ALLOWUNDO     // with facility to undo op
     or  ShellAPI . FOF_NOCONFIRMATION       // and we don't want any dialogs
     or  ShellAPI . FOF_SILENT ;
   end ;
   // Perform the operation
   Result  :=  ShellAPI . SHFileOperation ( FOS )  =  0 ;
end ;

function  DirToPath ( const  Dir :  string ):  string ;
{Returns the given directory with a trailing backslash. If the directory
already ends in backslash it is returned unchanged.}
begin
   if  ( Dir  <>  '' )  and  ( Dir [ Length ( Dir )]  <>  '/' )  then
     Result  :=  Dir  +  '/'
   else
     Result  :=  Dir ;
end ;

function  DOSToUnixPath ( const  PathName :  string ):  string ;
{Converts a DOS path to a Unix path and returns it.}
begin
   Result  :=  SysUtils . StringReplace ( PathName ,  '/' ,  '/' ,  [ SysUtils . rfReplaceAll ]);
end ;

procedure  EnsureFolders ( Path :  string );
{Ensures that the given folder and all folders on its path exist, and creates
them if they do not. Uses recursion.}
var
   SlashPos :  Integer ;                     // position of last backslash in path
   SubPath :  string ;                       // immediate parent folder of given path
begin
   // Check there's a path to create
   if  Length ( Path )  =  0  then
     Exit ;
   // Remove any trailing '/'
   Path  :=  PathToDir ( Path );
   // Check if folder exists and quit if it does - we're done
   if  IsDirectory ( Path )  then
     Exit ;
   // Recursively call routine on immediate parent folder
   // remove bottomost folder from path - ie move up to parent folder
   SubPath  :=  Path ;
   SlashPos  :=  Length ( SubPath );
   while  ( SlashPos  >  2 )  and  ( SubPath [ SlashPos ]  <>  '/' )  do
     Dec ( SlashPos );
   Delete ( SubPath ,  SlashPos ,  Length ( Path )  -  SlashPos  +  1 );
   // do recursive call - ensures that parent folder of current path exist
   EnsureFolders ( SubPath );
   // Create this current folder now we know parent folder exists
   SysUtils . CreateDir ( Path );
end ;

function  GetFileDate ( const  FName :  string ):  Integer ;
{Returns modification date of given file encoded as integer.}
var
   FileH :  Integer ;                        // file handle
begin
   // Open file
   FileH  :=  SysUtils . FileOpen ( FName ,  SysUtils . fmOpenRead );
   if  FileH  =  - 1  then
     // Couldn't open file - return -1 to indicate can't get date
     Result  :=  - 1
   else
   begin
     // File opened OK - record date and close file
     Result  :=  SysUtils . FileGetDate ( FileH );
     SysUtils . FileClose ( FileH );
   end ;
end ;

function  GetFixedFileVerInfo ( const  FileName :  string ;
   var  FFI :  Windows . TVSFixedFileInfo ):  Boolean ;
{Extracts fixed version information from a file. If file contains version
information it is returned via FFI parameter and function returns true,
otherwise false is returned and FFI is undefined.}
var
   VerInfoBuf :  Pointer ;                   // points to memory storing version info
   VerInfoSize :  Integer ;                  // size of version info memory
   Dummy :  Windows . THandle ;                // unused parameter required by API function
   PFFI :  Pointer ;                         // points to fixed file info
   FFISize :  Windows . UINT ;                 // size of file file info returned from API (unused)
begin
   // Assume failure: sets zero result
   FillChar ( FFI ,  SizeOf ( FFI ),  0 );
   Result  :=  False ;
   // Get size of version info: there is none if this is zero
   VerInfoSize  :=  Windows . GetFileVersionInfoSize ( PChar ( FileName ),  Dummy );
   if  VerInfoSize  >  0  then
   begin
     // Allocate memory to store ver info
     GetMem ( VerInfoBuf ,  VerInfoSize );
     try
       // Get the version info, filling buffer
       if  Windows . GetFileVersionInfo (
         PChar ( FileName ),  Dummy ,  VerInfoSize ,  VerInfoBuf
         )  then
       begin
         // Get a pointer to fixed file info
         if  Windows . VerQueryValue ( VerInfoBuf ,  '/' ,  PFFI ,  FFISize )  then
         begin
           // Got pointer OK: record file version
           FFI  :=  Windows . PVSFixedFileInfo ( PFFI )^;
           Result  :=  True ;
         end ;
       end ;
     finally
       // Dispose of ver info storage
       FreeMem ( VerInfoBuf ,  VerInfoSize );
     end ;
   end ;
end ;

function  HasVerInfo ( const  FileName :  string ):  Boolean ;
{Returns true if the given file contains version information and false if
not.}
var
   Dummy :  Windows . THandle ;                // dummy variable required by API function
begin
   // API function returns size of ver info: 0 if none
   Result  :=  Windows . GetFileVersionInfoSize ( PChar ( FileName ),  Dummy )  >  0 ;
end ;

function  IsDirectory ( const  DirName :  string ):  Boolean ;
{Returns true if given name is a valid directory and false otherwise. DirName
can be any file system name (with or without trailing path delimiter).}
var
   Attr :  Integer ;                         // directory's file attributes
begin
   Attr  :=  SysUtils . FileGetAttr ( DirName );
   Result  :=  ( Attr  <>  - 1 )
     and  ( Attr  and  SysUtils . faDirectory  =  SysUtils . faDirectory );
end ;

function  IsURLShortcut ( const  ShortcutFile :  string ):  Boolean ;
{Returns true if the given file is a URL shortcut file and false if not.}
var
   Ini :  IniFiles . TIniFile ;                // used to read ini files
begin
   // File must exist
   if  SysUtils . FileExists ( ShortcutFile )  then
   begin
     // Open ini file and check value exists
     Ini  :=  IniFiles . TIniFile . Create ( ShortcutFile );
     try
       Result  :=  Ini . SectionExists ( 'InternetShortcut' )
         and  Ini . ValueExists ( 'InternetShortcut' ,  'URL' )
         and  ( Ini . ReadString ( 'InternetShortcut' ,  'URL' ,  '' )  <>  '' );
     finally
       Ini . Free ;
     end ;
   end
   else
     Result  :=  False ;
end ;

function  ListFiles ( const  Dir ,  Wildcard :  string ;
   const  List :  Classes . TStrings ):  Boolean ;
{Gets a list of the files and sub-directories of the given directory that
match the given wild card. The files are appended to the given string list.
Returns true if Dir is a valid directory and False if not. If Wildcard is not
specified, *.* is assumed.}
var
   FileSpec :  string ;                      // search file specification
   SR :  SysUtils . TSearchRec ;               // file search result
   Success :  Integer ;                      // success code for FindXXX routines
begin
   Assert ( Assigned ( List ));
   // Check if true directory and exit if not
   Result  :=  IsDirectory ( Dir );
   if  not  Result  then
     Exit ;
   // Build file spec from directory and wildcard
   FileSpec  :=  DirToPath ( Dir );
   if  Wildcard  =  ''  then
     FileSpec  :=  FileSpec  +  '*.*'
   else
     FileSpec  :=  FileSpec  +  Wildcard ;
   // Initialise search for matching files
   Success  :=  SysUtils . FindFirst ( FileSpec ,  SysUtils . faAnyFile ,  SR );
   try
     // Loop for all files in directory
     while  Success  =  0  do
     begin
       // only add true files or directories to list
       if  ( SR . Name  <>  '.' )  and  ( SR . Name  <>  '..' )
         and  ( SR . Attr  and  SysUtils . faVolumeId  =  0 )  then
         List . Add ( SR . Name );
       // get next file
       Success  :=  SysUtils . FindNext ( SR );
     end ;
   finally
     // Tidy up
     SysUtils . FindClose ( SR );
   end ;
end ;

function  LongToShortFilePath ( const  LongName :  string ):  string ;
{Converts the given long file name to the equivalent shortened DOS style 8.3
path.}
begin
   SetLength ( Result ,  Windows . MAX_PATH );
   SetLength (
     Result ,
     Windows . GetShortPathName (
     PChar ( LongName ),  PChar ( Result ),  Windows . MAX_PATH
     )
     );
end ;

function  PathToDir ( const  Path :  string ):  string ;
{Returns the given directory with any single trailing backslash removed. If
the directory does not end in a backslash it is returned unchanged.}
begin
   Result  :=  Path ;
   if  ( Path  <>  '' )  and  ( Path [ Length ( Path )]  =  '/' )  then
     Delete ( Result ,  Length ( Result ),  1 );
end ;

procedure  SetFileDate ( const  FName :  string ;  const  ADate :  Integer );
{Sets modification date of given file to given integer coded value.}
var
   FileH :  Integer ;                        // file handle
begin
   // Open file
   FileH  :=  SysUtils . FileOpen ( FName ,  SysUtils . fmOpenWrite );
   if  FileH  <>  - 1  then
   begin
     // File opened OK - set date and close file
     SysUtils . FileSetDate ( FileH ,  ADate );
     SysUtils . FileClose ( FileH );
   end ;
end ;

function  ShortToLongFilePath ( const  FilePath :  string ):  string ;
{Converts whole of given DOS style 8.3 path to long file path and returns it.
If path can't be converted then '' is returned.}
var
   PrevPath :  string ;                      // path before last file/dir in FilePath
   ExpandedName :  string ;                  // long form of file name
   SR :  SysUtils . TSearchRec ;               // record used by file find functions
   Success :  Integer ;                      // indicates success in finding a file
   // ---------------------------------------------------------------------------
   function  CountPathDelims ( const  Name :  string ):  Integer ;
     {Counts path separators in given name}
   var
     Idx :  Integer ;                        // loops thru name string
   begin
     Result  :=  0 ;
     for  Idx  :=  1  to  Length ( Name )  do
       if  SysUtils . IsPathDelimiter ( Name ,  Idx )  then
         Inc ( Result );
   end ;

   function  IsServerName ( const  Name :  string ):  Boolean ;
     {Returns true if Names is in form //Server/Share}
   begin
     Result  :=  ( SysUtils . AnsiPos ( '//' ,  Name )  =  1 )
       and  ( CountPathDelims ( Name )  =  3 );
   end ;
   // ---------------------------------------------------------------------------
begin
   // Check if we have a drive, server/share or root path, and exit if so
   // (we can't apply file search to any of these, so we return them unchanged
   if  ( FilePath  =  '' )
     or  ( FilePath  =  '/' )
     or  (( Length ( FilePath )  =  2 )  and  ( FilePath [ 2 ]  =  ':' ))
     or  (( Length ( FilePath )  =  3 )  and  ( FilePath [ 2 ]  =  ':' )  and  ( FilePath [ 3 ]  =  '/' ))
     or  IsServerName ( FilePath )  then
   begin
     Result  :=  FilePath ;
     Exit ;
   end ;
   // Do a file search on file: this is used to expand name
   Success  :=  SysUtils . FindFirst ( FilePath ,  SysUtils . faAnyFile ,  SR );
   try
     if  Success  =  0  then
       ExpandedName  :=  SR . FindData . cFileName
     else
       ExpandedName  :=  '' ;
   finally
     SysUtils . FindClose ( SR );
   end ;
   // Check if there's any part of path we've not handled, and convert it if so
   PrevPath  :=  SysUtils . ExtractFileDir ( FilePath );
   if  PrevPath  <>  ''  then
   begin
     // We have unprocessed part of path: expand that
     Result  :=  ShortToLongFilePath ( PrevPath );
     // Appended currently expanded name to path
     if  ( Result  <>  '' )  and  ( Result [ Length ( Result )]  <>  '/' )  then
       Result  :=  Result  +  '/' ;
     Result  :=  Result  +  ExpandedName ;
   end
   else
     // No earlier parts of path: just record expanded name
     Result  :=  ExpandedName ;
end ;

function  TempFileName ( const  Stub :  string ;  const  Create :  Boolean ):  string ;
{Returns a unique temporary file name in temporary folder. File name includes
first three characters of Stub followed by hexadecimal characters. If Create
is true file is created. Returns empty string on failure.}
begin
   // Get temporary folder
   SetLength ( Result ,  Windows . MAX_PATH );
   Windows . GetTempPath ( Windows . MAX_PATH ,  PChar ( Result ));
   // Get unique temporary file name (it is created as side effect of this call)
   if  Windows . GetTempFileName (
     PChar ( Result ),  PChar ( Stub ),  0 ,  PChar ( Result )
     )  <>  0  then
   begin
     // Succeeded
     Result  :=  PChar ( Result );
     if  not  Create  then
       // user doesn't want file creating: so we delete the file
       SysUtils . DeleteFile ( Result );
   end
   else
     // Failed
     Result  :=  '' ;
end ;

function  Touch ( const  FileName :  string ):  Boolean ;
{Sets modification date of given file to current date and time. Returns true
if date set successfully or false on error.}
var
   FileH :  Integer ;                        // handle of file
begin
   // Assume failure
   Result  :=  False ;
   // Try to open file: bail out if can't open
   FileH  :=  SysUtils . FileOpen (
     FileName ,  SysUtils . fmOpenWrite  or  SysUtils . fmShareDenyWrite
     );
   if  FileH  =  - 1  then
     Exit ;
   try
     // Set date to current date and time: return true if succeed
     if  SysUtils . FileSetDate (
       FileH ,  SysUtils . DateTimeToFileDate ( SysUtils . Now ())
       )  =  0  then
       Result  :=  True ;
   finally
     // Close the file
     SysUtils . FileClose ( FileH );
   end ;
end ;

function  URLFromShortcut ( const  Shortcut :  string ):  string ;
{Returns the URL referenced by the given URL shortcut file, or the empty
string if the given file is not a shortcut file.}
var
   Ini :  IniFiles . TIniFile ;                // object used to read shortcut file
begin
   // Return URL item from [InternetShortcut] section of shortcut file
   Ini  :=  IniFiles . TIniFile . Create ( Shortcut );
   try
     try
       Result  :=  Ini . ReadString ( 'InternetShortcut' ,  'URL' ,  '' );
     except ;
       // We return '' on error
       Result  :=  '' ;
     end ;
   finally
     Ini . Free ;
   end ;
end ;

function  ColorToRGBTriple ( const  C :  Graphics . TColor ):  Windows . TRGBTriple ;
{Converts a Delphi TColor value into an RGB triple value.}
var
   ColorRGB :  Integer ;                     // RGB value of C
begin
   ColorRGB  :=  Graphics . ColorToRGB ( C );
   Result . rgbtRed  :=  Windows . GetRValue ( ColorRGB );
   Result . rgbtGreen  :=  Windows . GetGValue ( ColorRGB );
   Result . rgbtBlue  :=  Windows . GetBValue ( ColorRGB );
end ;

procedure  DrawTextOutline ( const  Canvas :  Graphics . TCanvas ;  const  X ,  Y :  Integer ;
   const  Text :  string );
{Draws specified text in outline on a canvas. The top left corner of the text
is specified by X and Y parameters. Canvas' current brush and pen colours are
used to fill and outline the text respectively. If the canvas' current font is
not a vector font nothing is displayed.}
var
   OldBkMode :  Integer ;                    // stores previous background mode
begin
   OldBkMode  :=  Windows . SetBkMode ( Canvas . Handle ,  Windows . TRANSPARENT );
   Windows . BeginPath ( Canvas . Handle );
   Canvas . TextOut ( X ,  Y ,  Text );
   Windows . EndPath ( Canvas . Handle );
   Windows . StrokeAndFillPath ( Canvas . Handle );
   Windows . SetBkMode ( Canvas . Handle ,  OldBkMode );
end ;

procedure  MakeGreyScale ( const  SrcBmp :  Graphics . TBitmap ;
   const  Advanced :  Boolean );
{Converts a colour bitmap into a 24bit greyscale bitmap. Setting the Advanced
flag to true uses a more advanced algorithm for the conversion. When the flag
is false red, blue and green values are simply averaged. The provided colour
bitmap is overwritten by the greyscale bitmap.}
type
   // 24 bit bitmap scanline and pointer
   TRGBArray  =  array [ 0.. MaxInt  div  SizeOf ( Windows . TRGBTriple )  -  1 ]
     of  Windows . TRGBTriple ;
   PRGBArray  =  ^ TRGBArray ;
var
   J :  Integer ;                            // loops scanlines of bitmap
   I :  Integer ;                            // loops through pixels in scanline
   GreyColor :  Byte ;                       // grey equivalent of a pixel
   ScanLine :  PRGBArray ;                   // references scanline in a bitmap
   GreyBmp :  Graphics . TBitmap ;             // used to build grey bitmap
begin
   // Draw colour bitmap in 24 bit format onto temp bitmap
   GreyBmp  :=  Graphics . TBitmap . Create ;
   try
     GreyBmp . PixelFormat  :=  Graphics . pf24bit ;
     GreyBmp . Width  :=  SrcBmp . Width ;
     GreyBmp . Height  :=  SrcBmp . Height ;
     GreyBmp . Canvas . Draw ( 0 ,  0 ,  SrcBmp );
     if  GreyBmp . PixelFormat  <>  Graphics . pf24bit  then
       raise  SysUtils . Exception . Create (
         'MakeGrayScale() can''t convert bitmap to 24 bit'
         );
     // Convert bitmap to greyscale by processing scanlines
     for  J  :=  0  to  Pred ( GreyBmp . Height )  do
     begin
       ScanLine  :=  GreyBmp . ScanLine [ j ];
       for  I  :=  0  to  Pred ( GreyBmp . Width )  do
       begin
         if  Advanced  then
           // Advanced greyscale conversion:
           // we use weighting of red, green and blue
           GreyColor  :=  Windows . HiByte (
             ScanLine [ i ]. rgbtRed  *  77
             +  ScanLine [ i ]. rgbtGreen  *  151
             +  ScanLine [ i ]. rgbtBlue  *  28
             )
         else
           // Basic conversion:
           // we use average of colour values
           GreyColor  :=  (
             ScanLine [ i ]. rgbtRed
             +  ScanLine [ i ]. rgbtGreen
             +  ScanLine [ i ]. rgbtBlue
             )  div  3 ;
         ScanLine [ i ]. rgbtRed  :=  GreyColor ;
         ScanLine [ i ]. rgbtGreen  :=  GreyColor ;
         ScanLine [ i ]. rgbtBlue  :=  GreyColor ;
       end ;
     end ;
     // Copy greyscale bitmap to source
     SrcBmp . Assign ( GreyBmp );
   finally
     GreyBmp . Free ;
   end ;
end ;

function  RGBTripleToColor ( const  C :  Windows . TRGBTriple ):  Graphics . TColor ;
{Converts an RGB triple value into a Delphi TColor value.}
begin
   Result  :=  Windows . RGB ( C . rgbtRed ,  C . rgbtGreen ,  C . rgbtBlue );
end ;

function  BrowseURL ( const  URL :  string ):  Boolean ;
{Activates default browser or email client for given URL. Returns true if
browser/email client is uccessfully launched and false if not. Raises
exception if URL doesn't conform to a known valid protocol.}
begin
   if  not  IsValidURLProtocol ( URL )  then
     raise  SysUtils . Exception . CreateFmt ( '"%s" is not a valid URL' ,  [ URL ]);
   Result  :=  ExecAssociatedApp ( URL );
end ;

function  ColorToHTML ( const  Color :  Graphics . TColor ):  string ;
{Converts a Delphi TColor value into a string suitable for use in HTML or CSS
code. Any system colors (like clBtnFace) are mapped to the actual colour
according to the current Windows settings.}
var
   ColorRGB :  Integer ;
begin
   ColorRGB  :=  Graphics . ColorToRGB ( Color );
   Result  :=  SysUtils . Format (
     '#%0.2X%0.2X%0.2X' ,
     [ Windows . GetRValue ( ColorRGB ),
     Windows . GetGValue ( ColorRGB ),
       Windows . GetBValue ( ColorRGB )]
       );
end ;

function  DownloadURLToFile ( const  URL ,  FileName :  string ):  Boolean ;
{Downloads file at URL and stores in given file. Returns true if download
succeeds and false on failure. A connection to the internet must be open for
download to succeed.}
begin
   // URLDownloadFile returns true if URL exists even if file not created
   // hence we also check file has been created.
   Result  :=  Windows . Succeeded (
     UrlMon . URLDownloadToFile ( nil ,  PChar ( URL ),  PChar ( FileName ),  0 ,  nil )
     )  and  SysUtils . FileExists ( FileName );
end ;

function  IsValidURLProtocol ( const  URL :  string ):  Boolean ;
{Checks if the given URL is valid per RFC1738. Returns true is valid and false
if not.}
const
   CNumProtocols  =  10 ;                    // number of known protocols
   CProtocols :  array [ 1.. CNumProtocols ]  of  string  =  (
     // Array of valid protocols - per RFC 1738
     'ftp://' ,  'http://' ,  'gopher://' ,  'mailto:' ,  'news:' ,  'nntp://' ,
     'telnet://' ,  'wais://' ,  'file://' ,  'prospero://'
     );
var
   I :  Integer ;                            // loops thru known protocols
begin
   // Scan array of protocols checking for a match with start of given URL
   Result  :=  False ;
   for  I  :=  1  to  CNumProtocols  do
     if  Pos ( CProtocols [ I ],  SysUtils . LowerCase ( URL ))  <>  0  then
     begin
       Result  :=  True ;
       Break ;
     end ;
end ;

function  MakeSafeHTMLText ( TheText :  string ):  string ;
{Replaces any characters in the given text that are HTML-compatible with
suitable escaped versions and returns modified string.}
var
   Idx :  Integer ;                          // loops thru the given text
begin
   Result  :=  '' ;
   for  Idx  :=  1  to  Length ( TheText )  do
     case  TheText [ Idx ]  of
       '<' :                               // opens tags: replace with special char reference
         Result  :=  Result  +  '&lt;' ;
       '>' :                               // closes tags: replace with special char reference
         Result  :=  Result  +  '&gt;' ;
       '&' :                               // begins char references: replace with special char reference
         Result  :=  Result  +  '&amp;' ;
       '"' :                               // quotes (can be a problem in quoted attributes)
         Result  :=  Result  +  '&quot;' ;
       #0 .. #31 ,  #127 .. #255 :               // control and special chars: replace with encoding
         Result  :=  Result  +  '&#'  +  SysUtils . IntToStr ( Ord ( TheText [ Idx ]))  +  ';' ;
     else                                 // compatible text: pass thru
       Result  :=  Result  +  TheText [ Idx ];
     end ;
end ;

function  URLDecode ( const  S :  string ):  string ;
{Decodes the given encoded URL or URL query string. Raises exception if the
encoded URL is badly formed.}
var
   Idx :  Integer ;                          // loops thru chars in string
   Hex :  string ;                           // string of hex characters
   Code :  Integer ;                         // hex character code (-1 on error)
begin
   // Intialise result and string index
   Result  :=  '' ;
   Idx  :=  1 ;
   // Loop thru string decoding each character
   while  Idx  <=  Length ( S )  do
   begin
     case  S [ Idx ]  of
       '%' :
         begin
           // % should be followed by two hex digits - exception otherwise
           if  Idx  <=  Length ( S )  -  2  then
           begin
             // there are sufficient digits - try to decode hex digits
             Hex  :=  S [ Idx  +  1 ]  +  S [ Idx  +  2 ];
             Code  :=  SysUtils . StrToIntDef ( '$'  +  Hex ,  - 1 );
             Inc ( Idx ,  2 );
           end
           else
             // insufficient digits - error
             Code  :=  - 1 ;
           // check for error and raise exception if found
           if  Code  =  - 1  then
             raise  SysUtils . EConvertError . Create (
               'Invalid hex digit in URL'
               );
           // decoded OK - add character to result
           Result  :=  Result  +  Chr ( Code );
         end ;
       '+' :
         // + is decoded as a space
         Result  :=  Result  +  ' '
     else
       // All other characters pass thru unchanged
       Result  :=  Result  +  S [ Idx ];
     end ;
     Inc ( Idx );
   end ;
end ;

function  URLEncode ( const  S :  string ;  const  InQueryString :  Boolean ):  string ;
{Encodes the given string, making it suitable for use in a URL. The function
can encode strings for use in the main part of a URL (where spaces are
encoded as '%20') or in URL query strings (where spaces are encoded as '+'
characters). Set InQueryString to true to encode for a query string.}
var
   Idx :  Integer ;                          // loops thru characters in string
begin
   Result  :=  '' ;
   for  Idx  :=  1  to  Length ( S )  do
   begin
     case  S [ Idx ]  of
       'A' .. 'Z' ,  'a' .. 'z' ,  '0' .. '9' ,  '-' ,  '_' ,  '.' :
         Result  :=  Result  +  S [ Idx ];
       ' ' :
         if  InQueryString  then
           Result  :=  Result  +  '+'
         else
           Result  :=  Result  +  '%20' ;
     else
       Result  :=  Result  +  '%'  +  SysUtils . IntToHex ( Ord ( S [ Idx ]),  2 );
     end ;
   end ;
end ;

function  CompressWhiteSpace ( const  S :  string ):  string ;
{Returns a copy of given string with all white space characters replaced by
space characters and all sequences of white space replaced by a single space
character.}
var
   Idx :  Integer ;                          // loops thru all characters in string
   ResCount :  Integer ;                     // counts number of characters in result string
   PRes :  PChar ;                           // pointer to characters in result string
const
   // The white space characters we convert to spaces
   cWhiteSpace  =  [ #9 ,  #10 ,  #11 ,  #12 ,  #13 ,  ' ' ];
begin
   // Set length of result to length of source string and set pointer to it
   SetLength ( Result ,  Length ( S ));
   PRes  :=  PChar ( Result );
   // Reset count of characters in result string
   ResCount  :=  0 ;
   // Loop thru characters of source string
   Idx  :=  1 ;
   while  Idx  <=  Length ( S )  do
   begin
     if  S [ Idx ]  in  cWhiteSpace  then
     begin
       // Current char is white space: replace by space char and count it
       PRes ^  :=  ' ' ;
       Inc ( PRes );
       Inc ( ResCount );
       // Skip past any following white space
       Inc ( Idx );
       while  S [ Idx ]  in  cWhiteSpace  do
         Inc ( Idx );
     end
     else
     begin
       // Current char is not white space: copy it literally and count it
       PRes ^  :=  S [ Idx ];
       Inc ( PRes );
       Inc ( ResCount );
       Inc ( Idx );
     end ;
   end ;
   // Reduce length of result string if it is shorter than source string
   if  ResCount  <  Length ( S )  then
     SetLength ( Result ,  ResCount );
end ;

function  CountDelims ( const  S ,  Delims :  string ):  Integer ;
{Returns count of all occurences of any of the given delimiter characters in
the string S.}
var
   Idx :  Integer ;                          //loops thru all characters in string
begin
   Result  :=  0 ;
   for  Idx  :=  1  to  Length ( S )  do
     if  SysUtils . IsDelimiter ( Delims ,  S ,  Idx )  then
       Inc ( Result );
end ;

function  ExplodeStr ( S :  string ;  const  Delim :  Char ;  const  List :  Classes . TStrings ;
   const  AllowEmpty :  Boolean  =  True ):  Integer ;
{Splits the string S into a list of strings, separated by Delim, and returns
the number of strings in the list. If AllowEmpty is true then any empty
strings are added to the list, while they are ignored if AllowEmpty is
false.}
var
   Item :  string ;                          // current delimted text
   Remainder :  string ;                     // remaining unconsumed part of string
begin
   // Clear the list
   List . Clear ;
   // Check we have some entries in the string
   if  S  <>  ''  then
   begin
     // Repeatedly split string until we have no more entries
     while  SplitStr ( S ,  Delim ,  Item ,  Remainder )  do
     begin
       // Add the current string, is required
       if  ( Item  <>  '' )  or  AllowEmpty  then
         List . Add ( Item );
       // Go round again with remainder of string
       S  :=  Remainder ;
     end ;
     // Add any terminal item
     if  ( Item  <>  '' )  or  AllowEmpty  then
       List . Add ( Item );
   end ;
   // Return number of items read
   Result  :=  List . Count ;
end ;

function  IsHexStr ( const  S :  string ):  Boolean ;
{Returns true if string S contains only valid hex digits, false otherwise.}
{Returns true if string S contains only valid hex digits, false otherwise}
const
   cHexChars  =  [ '0' .. '9' ,  'A' .. 'F' ,  'a' .. 'f' ];  // set of valid hex digits
var
   Idx :  Integer ;                          //loops thru all characters in string
begin
   Result  :=  True ;
   for  Idx  :=  1  to  Length ( S )  do
     if  not  ( S [ Idx ]  in  cHexChars )  then
     begin
       Result  :=  False ;
       Break ;
     end ;
end ;

function  JoinStr ( const  SL :  Classes . TStrings ;  const  Delim :  string ;
   const  AllowEmpty :  Boolean  =  True ):  string ;
{Joins all strings in given string list together into single string separated
by given delimiter. If AllowEmpty is true then any empty strings are included
in output string, but are ignored if false.}
var
   Idx :  Integer ;                          // loops thru all items in string list
begin
   Result  :=  '' ;
   for  Idx  :=  0  to  Pred ( SL . Count )  do
   begin
     if  ( SL [ Idx ]  <>  '' )  or  AllowEmpty  then
       if  Result  =  ''  then
         Result  :=  SL [ Idx ]
       else
         Result  :=  Result  +  Delim  +  SL [ Idx ];
   end ;
end ;

procedure  MultiSzToStrings ( const  MultiSz :  PChar ;
   const  Strings :  Classes . TStrings );
{Splits out individual strings from given 'MultiSz' strings buffer and adds
each string to the given string list. A MultiSz string is a sequence of #0
delimited strings terminated by an extra #0 character. Does nothing if string
list or MultiSz buffer are nil.}
var
   P :  PChar ;                              // pointer to strings in buffer
begin
   // Do nothing in MultiSz is nil
   if  not  Assigned ( MultiSz )  then
     Exit ;
   // Scan thru #0 delimited strings until #0#0 found
   P  :=  MultiSz ;
   while  P ^  <>  #0  do
   begin
     // add string to list
     Strings . Add ( P );
     // move pointer to start of next string if any
     Inc ( P ,  SysUtils . StrLen ( P )  +  1 );
   end ;
end ;

function  ParseDelims ( const  TextLine :  string ;  var  StartPos :  Integer ;
   const  Delims :  string ):  string ;
{Returns the sub-string of TextLine that begins at StartPos and is terminated
by one of the delimiting characters Delims or the end of the string. StartPos
is updated to index of character after delimiter. Returns '' if there is no
sub-string after StartPos.}
var
   StringEnd :  Integer ;                    // tracks end of current string being parsed out
begin
   // Find next non-delimiter char - this is where token starts
   while  ( StartPos  <=  Length ( TextLine ))
     and  SysUtils . IsDelimiter ( Delims ,  TextLine ,  StartPos )  do
     Inc ( StartPos );
   // Now find next delimiter - this is where token ends
   StringEnd  :=  StartPos ;
   while  ( StringEnd  <=  Length ( TextLine ))
     and  not  SysUtils . IsDelimiter ( Delims ,  TextLine ,  StringEnd )  do
     Inc ( StringEnd );
   // Copy result out of string
   Result  :=  Copy ( TextLine ,  StartPos ,  StringEnd  -  StartPos );
   StartPos  :=  StringEnd  +  1 ;
end ;

function  SplitStr ( const  S :  string ;  Delim :  Char ;  out  S1 ,  S2 :  string ):  Boolean ;
{Splits the string S at the first occurence of delimiter character Delim and
sets S1 to the sub-string before Delim and S2 to substring following Delim.
If Delim is found in string True is returned, while if Delim is not in string
False is returned, S1 is set to S and S2 is set to ''.}
var
   DelimPos :  Integer ;                     // position of delimiter in source string
begin
   // Find position of first occurence of delimter in string
   DelimPos  :=  SysUtils . AnsiPos ( Delim ,  S );
   if  DelimPos  >  0  then
   begin
     // Delimiter found: do split and return True
     S1  :=  Copy ( S ,  1 ,  DelimPos  -  1 );
     S2  :=  Copy ( S ,  DelimPos  +  1 ,  MaxInt );
     Result  :=  True ;
   end
   else
   begin
     // Delimeter not found: return false and set S1 to whole string
     S1  :=  S ;
     S2  :=  '' ;
     Result  :=  False ;
   end ;
end ;

function  StringsToMutliSz ( const  Strings :  Classes . TStrings ;
   const  MultiSz :  PChar ;  const  BufSize :  Integer ):  Integer ;
{Copies the strings from a given string list and stores in a provided MulitiSz
buffer of a given size. The strings in the buffer are separated by #0 and the
buffer is terminated by an additional #0. Returns 0 on success or required
buffer size if MultiSz is nil or buffer size is too small. To get required
buffer size call function with MultiSz=nil and BufSize=0.}
var
   ReqSize :  Integer ;                      // required buffer size
   Idx :  Integer ;                          // loops thru Strings
   P :  PChar ;                              // pointer into MultiSz
begin
   Result  :=  0 ;
   if  not  Assigned ( Strings )  then
     Exit ;
   // Get required size of buffer
   ReqSize  :=  1 ;
   for  Idx  :=  0  to  Pred ( Strings . Count )  do
     Inc ( ReqSize ,  Length ( Strings [ Idx ])  +  1 );
   if  ( BufSize  >=  ReqSize )  and  Assigned ( MultiSz )  then
   begin
     // BufSize OK and MultiSz not nil: copy string and return zero
     P  :=  MultiSz ;
     for  Idx  :=  0  to  Pred ( Strings . Count )  do
     begin
       // copy current string, #0 terminated
       SysUtils . StrPCopy ( P ,  Strings [ Idx ]);
       // moves to next pos in buffer
       Inc ( P ,  Length ( Strings [ Idx ])  +  1 );
     end ;
     // add terminating additional #0
     P ^  :=  #0 ;
   end
   else
     // BufSize too small or MultiSz is nil: return required size
     Result  :=  ReqSize ;
end ;

function  GetMacAddress :  string ;
{Returns MAC address of first ethernet adapter on computer.}
type
   // This type is defined in MSDN sample code, but tests have found this is
   // not needed (on XP Pro) and Adapter can be of type TAdapterStatus. This
   // method use the type in case other OSs require it
   TAStat  =  packed  record
     Adapt :  Nb30 . TAdapterStatus ;
     NameBuff :  array [ 0..29 ]  of  Nb30 . TNameBuffer ;
   end ;
var
   Adapter :  TAStat ;                       // info about a network adapter
   AdapterList :  Nb30 . TLanaEnum ;           // numbers for current LAN adapters
   Ncb :  Nb30 . TNCB ;                        // network control block descriptor
   I :  Integer ;                            // loops thru all adapters in list
   // ---------------------------------------------------------------------------
   function  NetBiosSucceeded ( const  RetCode :  AnsiChar ):  Boolean ;
   begin
     // Check RetCode is good NetBios function return value
     Result  :=  Windows . UCHAR ( RetCode )  =  Nb30 . NRC_GOODRET ;
   end ;
   // ---------------------------------------------------------------------------
begin
   // Assume not adapter
   Result  :=  '' ;
   // Get list of adapters
   FillChar ( Ncb ,  SizeOf ( Ncb ),  0 );
   Ncb . ncb_command  :=  AnsiChar ( Nb30 . NCBENUM );
   Ncb . ncb_buffer  :=  PAnsiChar (@ AdapterList );
   Ncb . ncb_length  :=  SizeOf ( AdapterList );
   if  not  NetBiosSucceeded ( Nb30 . Netbios (@ Ncb ))  then
     Exit ;
   // Get status of each adapter, exiting when first valid one reached
   // MSDN cautions us not to assume lana[0] is valid
   for  I  :=  0  to  Pred ( Integer ( AdapterList . length ))  do
   begin
     // reset the adapter
     FillChar ( Ncb ,  SizeOf ( Ncb ),  0 );
     Ncb . ncb_command  :=  AnsiChar ( Nb30 . NCBRESET );
     Ncb . ncb_lana_num  :=  AdapterList . lana [ I ];
     if  not  NetBiosSucceeded ( Nb30 . Netbios (@ Ncb ))  then
       Exit ;
     // get status of adapter
     FillChar ( Ncb ,  SizeOf ( Ncb ),  0 );
     Ncb . ncb_command  :=  AnsiChar ( Nb30 . NCBASTAT );
     Ncb . ncb_lana_num  :=  AdapterList . lana [ I ];
     Ncb . ncb_callname  :=  '*               ' ;
     Ncb . ncb_buffer  :=  PAnsiChar (@ Adapter );
     Ncb . ncb_length  :=  SizeOf ( Adapter );
     if  NetBiosSucceeded ( Nb30 . Netbios (@ Ncb ))  then
     begin
       // we have a MAC address: return it
       with  Adapter . Adapt  do
         Result  :=  SysUtils . Format (
           '%.2x-%.2x-%.2x-%.2x-%.2x-%.2x' ,
           [
           Ord ( adapter_address [ 0 ]),
             Ord ( adapter_address [ 1 ]),
             Ord ( adapter_address [ 2 ]),
             Ord ( adapter_address [ 3 ]),
             Ord ( adapter_address [ 4 ]),
             Ord ( adapter_address [ 5 ])
             ]
             );
       Exit ;
     end ;
   end ;
end ;

function  IsLockKeyOn ( const  KeyCode :  Integer ):  Boolean ;
{Detects if a given lock key is on and returns true if so. An exception is
raised if KeyCode is not a valid lock key code. Valid lock key codes are
VK_CAPITAL, VK_NUMLOCK and VK_SCROLL.}
begin
   if  not  (
     KeyCode  in  [ Windows . VK_CAPITAL ,  Windows . VK_NUMLOCK ,  Windows . VK_SCROLL ]
     )  then
     raise  SysUtils . Exception . Create ( 'Invalid lock key specified.' );
   Result  :=  Odd ( Windows . GetKeyState ( KeyCode ));
end ;

procedure  SetLockKeyState ( KeyCode :  Integer ;  IsOn :  Boolean );
{Sets the given lock key state to given value. Passing True switches lock key
on and passing False switches it off. An exception is raised if KeyCode is
not a valid lock key code. Valid lock key codes are VK_CAPITAL, VK_NUMLOCK
and VK_SCROLL.}
// ---------------------------------------------------------------------------
   procedure  MoveKey ( KeyCode :  Integer ;  Up :  Boolean );
   var
     Flags :  Integer ;                      // flags for MapVirtualKey()
   begin
     // Set up flags
     Flags  :=  Windows . KEYEVENTF_EXTENDEDKEY ;
     if  Up  then
       Flags  :=  Flags  or  Windows . KEYEVENTF_KEYUP ;
     // Simulate key movement
     Windows . keybd_event (
       KeyCode ,
       Windows . MapVirtualkey ( KeyCode ,  0 ),
       Flags ,
       0
       );
   end ;
   // ---------------------------------------------------------------------------
begin
   if  not  (
     KeyCode  in  [ Windows . VK_CAPITAL ,  Windows . VK_NUMLOCK ,  Windows . VK_SCROLL ]
     )  then
     raise  SysUtils . Exception . Create ( 'Invalid lock key specified.' );
   if  IsLockKeyOn ( KeyCode )  <>  IsOn  then
   begin
     // Need to change state: press & release key
     MoveKey ( KeyCode ,  False );
     MoveKey ( KeyCode ,  True );
   end ;
end ;

procedure  AddToRecentDocs ( const  FileName :  string );
{Adds given file to Recent Documents folder that appears on the Start menu.}
begin
   ShlObj . SHAddToRecentDocs ( ShlObj . SHARD_PATH ,  PChar ( FileName ));
end ;

procedure  ClearRecentDocs ;
{Clears the Recent Documents folder so that no recent documents appear on
Start menu.}
begin
   ShlObj . SHAddToRecentDocs ( ShlObj . SHARD_PATH ,  nil );
end ;

function  CreateShellLink ( const  LinkFileName ,  AssocFileName ,  Desc ,  WorkDir ,
   Args ,  IconFileName :  string ;  const  IconIdx :  Integer ):  Boolean ;
{Creates a shell link named LinkFileName that is a shortcut to file
AssocFileName with descriprion Desc. The shortcut activates its file in the
given working directory and passes the given command line Args to
AssocFileName. If an icon file and index offset are provided the specified
icon is used for the shortcut. True is returned on success and false on
error.}
var
   SL :  ShlObj . IShellLink ;                 // shell link object
   PF :  ActiveX . IPersistFile ;              // persistant file interface to shell link object
begin
   // Assume failure
   Result  :=  False ;
   // Ensure COM is initialised
   ActiveX . CoInitialize ( nil );
   try
     // Create shell link object
     if  ActiveX . Succeeded (
       ActiveX . CoCreateInstance (
       ShlObj . CLSID_ShellLink ,
       nil ,
       ActiveX . CLSCTX_INPROC_SERVER ,
       ShlObj . IShellLink ,  SL
       )
       )  then
     begin
       // Store required properties of shell link
       SL . SetPath ( PChar ( AssocFileName ));
       SL . SetDescription ( PChar ( Desc ));
       SL . SetWorkingDirectory ( PChar ( WorkDir ));
       SL . SetArguments ( PChar ( Args ));
       if  ( IconFileName  <>  '' )  and  ( IconIdx  >=  0 )  then
         SL . SetIconLocation ( PChar ( IconFileName ),  IconIdx );
       // Create persistant file interface to shell link to save link file
       PF  :=  SL  as  ActiveX . IPersistFile ;
       Result  :=  ActiveX . Succeeded (
         PF . Save ( PWideChar ( WideString ( LinkFileName )),  True )
         );
     end ;
   finally
     // Finalize COM
     ActiveX . CoUninitialize ;
   end ;
end ;

function  EmptyRecycleBin :  Boolean ;
{Empties the recycle bin. Returns returns true if bin is emptied and false if
the function fails.}
const
   // Flags passed to SHEmptyRecycleBin
   SHERB_NOCONFIRMATION  =  $00000001 ;
   SHERB_NOPROGRESSUI  =  $00000002 ;
   SHERB_NOSOUND  =  $00000004 ;
   // DLL containing function
   cDLLName  =  'Shell32.dll' ;
   // Function name
   cFnName  =  'SHEmptyRecycleBinA' ;
type
   // Prototype of API function
   TSHEmptyRecycleBin  =  function (
     Wnd :  Windows . HWND ;
     pszRootPath :  PChar ;
     dwFlags :  Windows . DWORD
     ):  HRESULT ;  stdcall ;
var
   SHEmptyRecycleBin :  TSHEmptyRecycleBin ;  // API function address
   DLLHandle :  Windows . THandle ;            // Handle of required DLL
begin
   // Assume failure
   Result  :=  False ;
   // Load required DLL
   DLLHandle  :=  Windows . LoadLibrary ( cDLLName );
   if  DLLHandle  <>  0  then
   begin
     try
       // Get reference of API function from DLL
       @ SHEmptyRecycleBin  :=  Windows . GetProcAddress ( DLLHandle ,  cFnName );
       if  Assigned (@ SHEmptyRecycleBin )  then
       begin
         // Try to empty recycle bin
         Result  :=  Windows . Succeeded (
           SHEmptyRecycleBin (
           0 ,
           nil ,
           SHERB_NOCONFIRMATION  or  SHERB_NOSOUND  or  SHERB_NOPROGRESSUI
           )
           );
       end ;
     finally
       Windows . FreeLibrary ( DLLHandle );
     end ;
   end ;
end ;

function  ExecAndWait ( const  CommandLine :  string ):  Boolean ;
{Executes the given command line and waits for the program started by the
command line to exit. Returns true if the program returns a zero exit code
and false if the program doesn't start or returns a non-zero error code.}
var
   StartupInfo :  Windows . TStartupInfo ;     // start-up info passed to process
   ProcessInfo :  Windows . TProcessInformation ;  // info about the process
   ProcessExitCode :  Windows . DWord ;        // process's exit code
begin
   // Set default error result
   Result  :=  False ;
   // Initialise startup info structure to 0, and record length
   FillChar ( StartupInfo ,  SizeOf ( StartupInfo ),  0 );
   StartupInfo . cb  :=  SizeOf ( StartupInfo );
   // Execute application commandline
   if  Windows . CreateProcess ( nil ,  PChar ( CommandLine ),
     nil ,  nil ,  False ,  0 ,  nil ,  nil ,
     StartupInfo ,  ProcessInfo )  then
   begin
     try
       // Now wait for application to complete
       if  Windows . WaitForSingleObject ( ProcessInfo . hProcess ,  INFINITE )
         =  WAIT_OBJECT_0  then
         // It's completed - get its exit code
         if  Windows . GetExitCodeProcess ( ProcessInfo . hProcess ,
           ProcessExitCode )  then
           // Check exit code is zero => successful completion
           if  ProcessExitCode  =  0  then
             Result  :=  True ;
     finally
       // Tidy up
       Windows . CloseHandle ( ProcessInfo . hProcess );
       Windows . CloseHandle ( ProcessInfo . hThread );
     end ;
   end ;
end ;

function  ExecAssociatedApp ( const  FileName :  string ):  Boolean ;
{Executes the application associated with the given file name. Returns true if
application is started successfully and false if not.}
begin
   Result  :=  ShellAPI . ShellExecute (
     0 ,
     nil ,
     PChar ( FileName ),
     nil ,
     nil ,
     Windows . SW_SHOW
     )  >  32 ;
end ;

function  ExploreFile ( const  Filename :  string ):  Boolean ;
{Starts Windows Explorer to explore given file. Returns true if file is valid
and can be explored, or false otherwise.}
var
   Params :  string ;                        // params passed to explorer
begin
   if  SysUtils . FileExists ( Filename )  then
   begin
     Params  :=  '/n, /e, /select, '  +  Filename ;
     Result  :=  ShellAPI . ShellExecute (
       0 ,  'open' ,  'explorer' ,  PChar ( Params ),  '' ,  Windows . SW_SHOWNORMAL
       )  >  32 ;
   end
   else
     // Error: filename does not exist
     Result  :=  False ;
end ;

function  ExploreFolder ( const  Folder :  string ):  Boolean ;
{Starts Windows Explorer to explore given folder. Returns true if folder is
valid and can be explored, or false otherwise.}
begin
   if  SysUtils . FileGetAttr ( Folder )  and  faDirectory  =  faDirectory  then
     // Folder is valid directory: try to explore it
     Result  :=  ShellAPI . ShellExecute (
       0 ,  'explore' ,  PChar ( Folder ),  nil ,  nil ,  Windows . SW_SHOWNORMAL
       )  >  32
   else
     // Folder is not a directory: error
     Result  :=  False ;
end ;

function  FileFromShellLink ( const  LinkFileName :  string ):  string ;
{Returns the fully specified name of the file associated with the given shell
link (shortcut) file. Returns '' if the file is not a shell link or if it is
a shortcut to a non-file shell object.}
var
   SL :  ShlObj . IShellLink ;                 // shell link object
   ResolvedFileBuf :  array [ 0.. Windows . MAX_PATH ]  of  AnsiChar ;
   // buffer to receive linked file name
   FindData :  Windows . TWin32FindData ;      // dummy required for IShellLink.GetPath()
begin
   // Assume can't get name of file
   Result  :=  '' ;
   // Ensure COM is initialized
   ActiveX . CoInitialize ( nil );
   try
     // Try to get interface to shell link: fails if file is not shell link
     SL  :=  LoadShellLink ( LinkFileName );
     if  not  Assigned ( SL )  then
       Exit ;
     // Get file path from link object and exit if this fails
     if  ActiveX . Failed (
       SL . GetPath ( ResolvedFileBuf ,  Windows . MAX_PATH ,  FindData ,  0 )
       )  then
       Exit ;
     // Return file name
     Result  :=  ResolvedFileBuf ;
   finally
     // Finalize COM
     ActiveX . CoUninitialize ;
   end ;
end ;

function  FindAssociatedApp ( const  Doc :  string ):  string ;
{Returns the fully specified path of the program associated with the given
document file name. Requires ShellAPI. Returns empty string if no such
associated application.}
var
   PExecFile :  array [ 0.. Windows . MAX_PATH ]  of  Char ;  // buffer to hold exe name
begin
   // Win API call in ShellAPI
   if  ShellAPI . FindExecutable ( PChar ( Doc ),  nil ,  PExecFile )  <  32  then
     // No associated program found
     Result  :=  ''
   else
     // Return program file name
     Result  :=  PExecFile ;
end ;

procedure  FreePIDL ( PIDL :  ShlObj . PItemIDList );
{Uses to shell allocator to free the memory used by a given PIDL.}
var
   Malloc :  ActiveX . IMalloc ;               // shell's allocator
begin
   // Try to get shell allocator
   if  Windows . Succeeded ( ShlObj . SHGetMalloc ( Malloc ))  then
     // Use allocator to free PIDL: Malloc is freed by Delphi
     Malloc . Free ( PIDL );
end ;

function  IsShellLink ( const  LinkFileName :  string ):  Boolean ;
{Checks if the given file is a shell link.}
begin
   // Ensure COM is initialized
   ActiveX . CoInitialize ( nil );
   try
     // Valid shell link if we can load it
     Result  :=  Assigned ( LoadShellLink ( LinkFileName ));
   finally
     // Finalize COM
     ActiveX . CoUninitialize ;
   end ;
end ;

function  IsSpecialFolderSupported ( CSIDL :  Integer ):  Boolean ;
{Returns true if the given special folder specified by a CSIDL is supported on
the system and false if not.}
var
   PIDL :  ShlObj . PItemIDList ;              // PIDL of the special folder
begin
   // Try to get PIDL for folder: fails if not supported
   Result  :=  Windows . Succeeded (
     ShlObj . SHGetSpecialFolderLocation ( 0 ,  CSIDL ,  PIDL )
     );
   if  Result  then
     // Free the PIDL using shell allocator
     FreePIDL ( PIDL );
end ;

function  LoadShellLink ( const  LinkFileName :  string ):  ShlObj . IShellLink ;
{Loads a shell link file into a shell link object and returns the IShellLink
interface of the object. If the given file is not a shell link nil is
returned. The returned object can be used to access information about the
shell link.}
var
   PF :  ActiveX . IPersistFile ;              // persistent file interface to shell link object
begin
   // Create shell link object
   if  ActiveX . Succeeded (
     ActiveX . CoCreateInstance (
     ShlObj . CLSID_ShellLink ,
     nil ,
     ActiveX . CLSCTX_INPROC_SERVER ,
     ShlObj . IShellLink ,
     Result
     )
     )  then
   begin
     // Try to load the shell link: succeeds only of file is shell link
     PF  :=  Result  as  ActiveX . IPersistFile ;
     if  ActiveX . Failed (
       PF . Load ( PWideChar ( WideString ( LinkFileName )),  ActiveX . STGM_READ )
       )  then
       Result  :=  nil ;                     // this frees the shell link object
   end
   else
     Result  :=  nil ;
end ;

function  OpenFolder ( const  Folder :  string ):  Boolean ;
{Opens given folder in Windows Explorer. Returns true if folder is valid and
can be opened, or false otherwise.}
begin
   if  SysUtils . FileGetAttr ( Folder )  and  faDirectory  =  faDirectory  then
     // Folder is valid directory: try to open it
     Result  :=  ShellAPI . ShellExecute (
       0 ,  'open' ,  PChar ( Folder ),  nil ,  nil ,  Windows . SW_SHOWNORMAL
       )  >  32
   else
     // Folder is not a directory: error
     Result  :=  False ;
end ;

function  PIDLToFolderPath ( PIDL :  ShlObj . PItemIDList ):  string ;
{Returns the full path to a file system folder from a PIDL or '' if the PIDL
refers to a virtual folder.}
begin
   // Set max length of return string
   SetLength ( Result ,  Windows . MAX_PATH );
   // Get the path
   if  ShlObj . SHGetPathFromIDList ( PIDL ,  PChar ( Result ))  then
     Result  :=  PChar ( Result )
   else
     Result  :=  '' ;
end ;

function  ShowFindFilesDlg ( const  Folder :  string ):  Boolean ;
{Displays the Windows find files dialog box ready for searching the given
folder. Returns true if dialog is shown and false if can't be shown (e.g. if
given folder is not valid).}
begin
   Result  :=  ShellAPI . ShellExecute (
     0 ,  'find' ,  PChar ( Folder ),  '' ,  '' ,  Windows . SW_SHOW
     )  >  32 ;
end ;

function  SpecialFolderPath ( CSIDL :  Integer ):  string ;
{Returns the full path to a special file system folder specified by a CSIDL
constant FolderID or '' if the special folder is virtual or CSIDL is not
supported.}
var
   PIDL :  ShlObj . PItemIDList ;              // PIDL of the special folder
begin
   Result  :=  '' ;
   // Get PIDL for required folder
   if  Windows . Succeeded (
     ShlObj . SHGetSpecialFolderLocation ( 0 ,  CSIDL ,  PIDL )
     )  then
   begin
     try
       // Get path from PIDL
       Result  :=  PIDLToFolderPath ( PIDL );
     finally
       // Free the PIDL using shell allocator
       FreePIDL ( PIDL );
     end ;
   end
end ;

function  TaskAllocWideString ( const  S :  string ):  Windows . PWChar ;
{Converts a given ANSI string to a wide string and stores in a buffer
allocated by the Shell's task allocator. If the buffer needs to be freed
IMalloc.Free should be used to do this.}
var
   StrLen :  Integer ;                       // length of string in bytes
begin
   // Store length of string allowing for terminal #0
   StrLen  :=  Length ( S )  +  1 ;
   // Alloc buffer for wide string using task allocator
   Result  :=  ActiveX . CoTaskMemAlloc ( StrLen  *  SizeOf ( WideChar ));
   if  Assigned ( Result )  then
     // Convert string to wide string and store in buffer
     StringToWideChar ( S ,  Result ,  StrLen );
end ;

function  TaskbarHandle :  Windows . THandle ;
{Returns the window handle of the Windows task bar.}
begin
   Result  :=  Windows . FindWindow ( 'Shell_TrayWnd' ,  nil );
end ;

function  CommonFilesFolder :  string ;
{Returns directory used for common files.}
begin
   Result  :=  GetCurrentVersionRegStr ( 'CommonFilesDir' );
end ;

function  GetCurrentVersionRegStr ( const  ValName :  string ):  string ;
{Gets given string value from given subkey of Windows current version registry
key.}
const
   cWdwCurrentVer  =  '/Software/Microsoft/Windows/CurrentVersion' ;
begin
   Result  :=  GetRegistryString (
     Windows . HKEY_LOCAL_MACHINE ,
     cWdwCurrentVer ,
     ValName
     );
end ;

function  GetRegistryString ( const  RootKey :  Windows . HKEY ;
   const  SubKey ,  Name :  string ):  string ;
{Gets a string value from the registry from the given root and sub key.
Converts integers to strings and raises exception for binary and unknown
value types. Returns '' if the sub key or value name are not known.}
var
   Reg :  Registry . TRegistry ;               // registry access object
   ValueInfo :  Registry . TRegDataInfo ;      // info about registry value
begin
   Result  :=  '' ;
   // Open registry at required root key
   Reg  :=  Registry . TRegistry . Create ;
   try
     Reg . RootKey  :=  RootKey ;
     // Open registry key and check value exists
     if  Reg . OpenKeyReadOnly ( SubKey )
       and  Reg . ValueExists ( Name )  then
     begin
       // Check if registry value is string or integer
       Reg . GetDataInfo ( Name ,  ValueInfo );
       case  ValueInfo . RegData  of
         Registry . rdString ,  Registry . rdExpandString :
           // string value: just return it
           Result  :=  Reg . ReadString ( Name );
         Registry . rdInteger :
           // integer value: convert to string
           Result  :=  SysUtils . IntToStr ( Reg . ReadInteger ( Name ));
       else
         // unsupported value: raise exception
         raise  SysUtils . Exception . Create (
           'Unsupported registry type'
           );
       end ;
     end ;
   finally
     // Close registry
     Reg . Free ;
   end ;
end ;

function  IsIntResource ( const  ResID :  PChar ):  Boolean ;
{Returns true if the given resource ID is integer value or false if the ID is
a pointer to a zero terminated string.}
begin
   Result  :=  ( Windows . HiWord ( Windows . DWORD ( ResID ))  =  0 );
end ;

function  IsMediaCenterOS :  Boolean ;
{Returns true if the operating system is a Windows Media Center edition or
false if not.}
const
   SM_MEDIACENTER  =  87 ;                   // metrics flag not defined in Windows unit
begin
   Result  :=  Windows . GetSystemMetrics ( SM_MEDIACENTER )  <>  0 ;
end ;

function  IsTabletOS :  Boolean ;
{Returns true if the operating system is a Windows Tablet edition or false if
not.}
const
   SM_TABLETPC  =  86 ;                      // metrics flag not defined in Windows unit
begin
   Result  :=  Windows . GetSystemMetrics ( SM_TABLETPC )  <>  0 ;
end ;

function  IsWin9x :  Boolean ;
{Returns true if the operating system is on the Windows 9x platform (including
Windows 95, 98 and Me) and false if not.}
begin
   Result  :=  SysUtils . Win32Platform  =  Windows . VER_PLATFORM_WIN32_WINDOWS ;
end ;

function  IsWinNT :  Boolean ;
{Returns true if the operating system is Windows NT (including 2000 and XP)
and false if not.}
begin
   Result  :=  ( SysUtils . Win32Platform  =  Windows . VER_PLATFORM_WIN32_NT );
end ;

function  IsWow64 :  Boolean ;
{Returns true if the current process is executing as a 32 bit process under
WOW64 on 64 bit Windows.}
type
   TIsWow64Process  =  function (            // Type of IsWow64Process API fn
     Handle :  Windows . THandle ;  var  Res :  Windows . BOOL
     ):  Windows . BOOL ;  stdcall ;
var
   IsWow64Result :  Windows . BOOL ;           // Result from IsWow64Process
   IsWow64Process :  TIsWow64Process ;       // IsWow64Process fn reference
begin
   // Try to load required function from kernel32
   IsWow64Process  :=  Windows . GetProcAddress (
     Windows . GetModuleHandle ( 'kernel32' ),  'IsWow64Process'
     );
   if  Assigned ( IsWow64Process )  then
   begin
     // Function is implemented: call it
     if  not  IsWow64Process (
       Windows . GetCurrentProcess ,  IsWow64Result
       )  then
       raise  SysUtils . Exception . Create ( 'IsWow64: bad process handle' );
     // Return result of function
     Result  :=  IsWow64Result ;
   end
   else
     // Function not implemented: can't be running on Wow64
     Result  :=  False ;
end ;

function  ProgramFilesFolder :  string ;
{Returns directory used for program files.}
begin
   Result  :=  GetCurrentVersionRegStr ( 'ProgramFilesDir' );
end ;

function  SystemFolder :  string ;
{Returns path to Windows system folder.}
begin
   SetLength ( Result ,  Windows . MAX_PATH );
   SetLength (
     Result ,  Windows . GetSystemDirectory ( PChar ( Result ),  Windows . MAX_PATH )
     );
end ;

function  TempFolder :  string ;
{Returns path to Windows temporary folder.}
begin
   SetLength ( Result ,  Windows . MAX_PATH );
   SetLength (
     Result ,  Windows . GetTempPath ( Windows . MAX_PATH ,  PChar ( Result ))
     );
end ;

function  WindowsFolder :  string ;
{Returns path to Windows folder.}
begin
   SetLength ( Result ,  Windows . MAX_PATH );
   SetLength (
     Result ,  Windows . GetWindowsDirectory ( PChar ( Result ),  Windows . MAX_PATH )
     );
end ;

function  WindowsProductID :  string ;
{Returns the Windows product ID.}
const
   // Registry keys for Win 9x/NT
   cRegKey :  array [ Boolean ]  of  string  =  (
     'Software/Microsoft/Windows/CurrentVersion' ,
     'Software/Microsoft/Windows NT/CurrentVersion'
     );
   // Registry key name
   cName  =  'ProductID' ;
begin
   Result  :=  GetRegistryString (
     Windows . HKEY_LOCAL_MACHINE ,  cRegKey [ IsWinNT ],  cName
     );
end ;

end .