home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d56 / RMCTL.ZIP / rmLibrary.pas < prev    next >
Pascal/Delphi Source File  |  2001-06-22  |  44KB  |  1,484 lines
  1. {================================================================================
  2. Copyright (C) 1997-2001 Mills Enterprise
  3.  
  4. Unit     : rmLibrary
  5. Purpose  : This unit provides commonly used routines not specific to any
  6.            component or control in the "rmComponent" set and is also required by
  7.            various other "rm" Controls
  8. Date     : 03-05-2000
  9. Author   : Ryan J. Mills
  10. Version  : 1.80
  11. ================================================================================}
  12.  
  13. unit rmLibrary;
  14.  
  15. interface
  16.  
  17. {$I CompilerDefines.INC}
  18.  
  19. uses windows, graphics, controls, classes, forms, sysutils, consts, Math, dialogs;
  20.  
  21. {$IFDEF BD5}
  22.   const
  23.      {$EXTERNALSYM COLOR_HOTLIGHT}
  24.      COLOR_HOTLIGHT = 26;
  25.  
  26.      {$EXTERNALSYM COLOR_GRADIENTACTIVECAPTION}
  27.      COLOR_GRADIENTACTIVECAPTION = 27;
  28.  
  29.      {$EXTERNALSYM COLOR_GRADIENTINACTIVECAPTION}
  30.      COLOR_GRADIENTINACTIVECAPTION = 28;
  31.  
  32.      clHotLight = TColor(COLOR_HOTLIGHT or $80000000) ;
  33.      clGradientActiveCaption = TColor(COLOR_GRADIENTACTIVECAPTION or $80000000) ;
  34.      clGradientInactiveCaption = TColor(COLOR_GRADIENTINACTIVECAPTION or $80000000) ;
  35. {$endif}
  36.  
  37. {Conversion Functions}
  38. function strtochar(st: string) : char;
  39. function chartostr(ch: char) : string;
  40. function BoolToStr(B: Boolean) : string;
  41. function StrToBool(st: String) : boolean;
  42. function SizeInt(x: comp) : string;
  43.  
  44. {Math functions}
  45. function IntInRange(Item, Low, High: integer) : boolean;
  46. function CompInRange(Item, Low, High: Comp) : Boolean;
  47. function SetInRange(Item, Low, High: integer) : integer;
  48. function GreaterThanInt(x1, x2: integer) : integer;
  49. function LessThanInt(x1, x2: integer) : integer;
  50. function GreaterThanFloat(x1, x2: Double) : Double;
  51. function LessThanFloat(x1, x2: Double) : Double;
  52.  
  53. { Rect }
  54. function RectWidth(Rect:TRect):integer;
  55. function RectHeight(Rect:TRect):integer;
  56. function RectDiameter(Rect:TRect) : integer; //Was CalculateImageDiameter
  57.  
  58. { MediaID }
  59. const
  60.      //File System IDs
  61.    fstFat = 1; //Fat
  62.    fstHPFS = 2; //High Performance File System
  63.    fstNTFS = 3; //NT File System
  64.    fstUnknown = 0; //UnknownFileSystem;
  65.  
  66.      //Media Info IDs
  67.    mispc = 1; //sectorsperclustor
  68.    mibps = 2; //bytespersector
  69.    mifc = 3; //freeclusters
  70.    mitc = 4; //totalclustors
  71.    mids = 5; //disksize
  72.    midf = 6; //diskfree
  73.    midsn = 7; //diskserialnumber
  74.    mics = 8; //clustersize
  75.    mifst = 9; //filesystemtype
  76.    mifsf = 10; //filesystemflags
  77.    mifsfnl = 11; //filesystemfilenamelength
  78.  
  79. function GetMediaInfo(Drive: byte; info: byte) : longint;
  80.  
  81. { Graphiks }
  82. type
  83.    TColorsArray = array of TColor;
  84.    TGradientFill = (gfLinear, gfRectangle, gfRoundRect, gfOval, gfRadial);
  85.  
  86. procedure CreateColorArray(Color1, Color2 : TColor; Steps:Integer; var Colors:TColorsArray);
  87. procedure GradientFillColors(Canvas: TCanvas; Colors:TColorsArray; R:TRect);
  88. procedure GradientFill(Canvas: TCanvas; FBeginColor, FEndColor: TColor; R: TRect; FillStyle:TGradientFill = gfLinear) ;
  89. procedure RotateImage(BitmapRotated, BitmapOriginal: tbitmap; angle: integer) ;
  90. procedure ReplaceColors(var bmp: TBitmap; BackGrnd, ForeGrnd: TColor) ;
  91. procedure DrawGrayText(Canvas: TCanvas; Text: string; var R: TRect; Flags: Integer) ;
  92. procedure RotateText(Canvas: TCanvas; Text: string;  var R: TRect; Angle: Integer);
  93.  
  94. { CRC32 }
  95. function GetFileCRC32(filename: string) : longint;
  96. function GetStrCRC32(Data: string) : longint;
  97. function GetStrmCRC32(Data: TStream) : longint;
  98.  
  99. {WinSock Functions}
  100. function LocalIP: string;
  101. function LocalName: string;
  102.  
  103. { Strings }
  104. type
  105.    TrmCharSet = set of char;
  106.  
  107. function ParseSection(ParseLine: string; ParseNum: Integer; ParseSep: Char) : string;
  108. function CountSections(St: string; ParseSep: char) : integer;
  109. function LeadingZero(Value, PadWidth: integer) : string;
  110. function PadLeft(Data: string; PadWidth: integer) : string;
  111. function PadRight(Data: string; PadWidth: integer) : string;
  112. function StripString(StrData: string; StripChars: TrmCharSet; ReplaceChar: char) : string;
  113. function rmDateTimeToStr(x: TDateTime) : string;
  114. function MaskStrCmp(mask, s: string) : boolean;
  115. function Soundex(InStr: string; StandardResult: boolean = True; Precision : integer = 4) : string;
  116.  
  117. { Shell }
  118. type
  119.    TShortcutDetails = record
  120.       Arguments: string;
  121.       Description: string;
  122.       HotKey: TShortCut;
  123.       IconFile: string;
  124.       IconIndex: Integer;
  125.       LinkName: string;
  126.       ShowCommand: TWindowState;
  127.       WorkingDirectory: string;
  128.    end;
  129.  
  130. function ReadShortCutFile(filename: string) : TShortcutDetails;
  131. procedure WriteShortCutFile(filename: string; Details: TShortcutDetails) ;
  132.  
  133. function GetFileType(FileName: string) : string;
  134. function GetFileIcon(FileName: string; SmallImage: Boolean) : TIcon;
  135. function GetFileImageIndex(Filename: string; SmallImage: boolean) : integer;
  136. function GetFileImages(AImageList: TImageList; SmallImage: boolean) : boolean;
  137.  
  138. { OS }
  139. type
  140.    TWinOSVersion = (wosWin3x, wosWin95, wosWin98, wosWinNT3x, wosWinNT4x, wosWinNT2k, wosWinNTX, wosUnknown) ;
  141.    TrmHkey = (HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_LOCAL_MACHINE, HKEY_USERS,
  142.       HKEY_PERFORMANCE_DATA, HKEY_CURRENT_CONFIG, HKEY_DYN_DATA) ;
  143.  
  144. function WinOSVersion: TWinOSVersion;
  145.  
  146. implementation
  147.  
  148. uses shellapi, ShlObj, WinSock, ActiveX;
  149.  
  150. var
  151.    ficon: TIcon;
  152.  
  153. { Generic }
  154.  
  155. const
  156.    HOTKEYF_SHIFT = $01;
  157.    HOTKEYF_CONTROL = $02;
  158.    HOTKEYF_ALT = $04;
  159.    HOTKEYF_EXT = $08;
  160.  
  161. function GetWindowState(State: integer) : TWindowState;
  162. begin
  163.    case State of
  164.       SW_SHOWNORMAL, SW_SHOW, SW_RESTORE: Result := wsNormal;
  165.       SW_SHOWMINIMIZED, SW_MINIMIZE, SW_SHOWMINNOACTIVE: Result := wsMinimized;
  166.       SW_SHOWMAXIMIZED, SW_MAX: Result := wsMaximized;
  167.    else
  168.       Result := wsNormal;
  169.    end;
  170. end;
  171.  
  172. function KeyToShortCut(HotKey: word) : TShortCut;
  173. begin
  174.    Result := WordRec(HotKey) .Lo;
  175.    if ((HotKey shr 8) and HOTKEYF_SHIFT) <> 0 then Inc(Result, scShift) ;
  176.    if ((HotKey shr 8) and HOTKEYF_CONTROL) <> 0 then Inc(Result, scCtrl) ;
  177.    if ((HotKey shr 8) and HOTKEYF_ALT) <> 0 then Inc(Result, scAlt) ;
  178. end;
  179.  
  180. function ShortCutToKey(ShortCut: TShortCut) : Word;
  181. var
  182.    Key: byte;
  183.    Shift: byte;
  184. begin
  185.    Key := ShortCut and not (scShift + scCtrl + scAlt) ;
  186.    Shift := 0;
  187.    if ShortCut and scShift <> 0 then Inc(Shift, HOTKEYF_SHIFT) ;
  188.    if ShortCut and scCtrl <> 0 then Inc(Shift, HOTKEYF_CONTROL) ;
  189.    if ShortCut and scAlt <> 0 then Inc(Shift, HOTKEYF_ALT) ;
  190.    Result := MakeWord(Key, Shift) ;
  191. end;
  192.  
  193. {Conversion Functions}
  194.  
  195. function strtochar(st: string) : char;
  196. var
  197.    wStr: string;
  198.    wInt: integer;
  199. begin
  200.    wstr := trim(st) ;
  201.    if wstr[1] = '#' then
  202.    begin
  203.       delete(wstr, 1, 1) ;
  204.  
  205.       wInt := strtoint(wstr) ;
  206.  
  207.       if (wInt >= 0) and (wInt < 256) then
  208.          result := chr(byte(wInt) )
  209.       else
  210.          raise EConvertError.create('Value must be between 0 and 255') ;
  211.    end
  212.    else
  213.    begin
  214.       if length(wstr) > 1 then
  215.          raise EConvertError.create('Invalid property value')
  216.       else
  217.          result := wstr[1];
  218.    end;
  219. end;
  220.  
  221. function chartostr(ch: char) : string;
  222. begin
  223.    if (integer(ch) < 33) or (integer(ch) > 255) then
  224.       result := '#' + inttostr(byte(ch) )
  225.    else
  226.       result := ch;
  227. end;
  228.  
  229. function BoolToStr(B: Boolean) : string;
  230. begin
  231.    case b of
  232.       true: result := 'True';
  233.       false: result := 'False';
  234.    end;
  235. end;
  236.  
  237. function StrToBool(st: String) : boolean;
  238. begin
  239.    st := lowercase(trim(st) ) ;
  240.    result := (st = 'true') ;
  241. end;
  242.  
  243. function SizeInt(x: comp) : string;
  244. begin
  245.    if CompInRange(x, 1023, 0) then
  246.       result := floattostrf(x, fffixed, 5, 0)
  247.    else if CompInRange(x, 1048575, 1024) then
  248.       result := floattostrf((x / 1024) , fffixed, 5, 0) + ' K'
  249.    else if CompInRange(x, 1073741823, 1048576) then
  250.       result := floattostrf((x / 1048576) , fffixed, 5, 1) + ' M'
  251.    else if x >= 1073741824 then
  252.       result := floattostrf((x / 1073741824) , fffixed, 5, 2) + ' G'
  253.    else
  254.       result := '';
  255. end;
  256.  
  257. { Rect }
  258. function RectWidth(Rect:TRect):integer;
  259. begin
  260.    result := (rect.Right-rect.Left);
  261. end;
  262.  
  263. function RectHeight(Rect:TRect):integer;
  264. begin
  265.    result := (rect.Bottom-rect.Top);
  266. end;
  267.  
  268. function RectDiameter(Rect:TRect) : integer;
  269. begin
  270.    try
  271.       result := round( RectHeight(Rect) / Sin( arcTan( RectHeight(Rect) / RectWidth(Rect) ) ) ) + 2
  272.    except
  273.       result := 0;
  274.    end;
  275. end;
  276.  
  277. {MediaID}
  278.  
  279. function GetMediaInfo(Drive: byte; info: byte) : longint;
  280. var
  281.    path, volumename, filesystem: string;
  282.    n1, n2, n3, n4: Cardinal;
  283. begin
  284.    result := -1;
  285.    if drive > 0 then
  286.       path := chr(drive + 64) + ':\';
  287.    if info in [mispc, mibps, mifc, mitc, mids, midf, mics] then
  288.    begin
  289.       if getdiskfreespace(pchar(path) , n1, n2, n3, n4) = true then
  290.       begin
  291.          case info of
  292.             mispc: Result := n1;
  293.             mibps: Result := n2;
  294.             mifc: Result := n3;
  295.             mitc: Result := n4;
  296.             mids: Result := n1 * n2 * n4;
  297.             midf: Result := n1 * n2 * n3;
  298.             mics: Result := n1 * n2;
  299.          end
  300.       end
  301.       else
  302.          Result := -1;
  303.    end
  304.    else if info in [midsn] then
  305.    begin
  306.       setlength(volumename, 255) ;
  307.       setlength(filesystem, 10) ;
  308.       getvolumeinformation(pchar(path) , pchar(volumename) , 255, @n1, n2, n3, pchar(filesystem) , 10) ;
  309.       case info of
  310.          midsn: Result := n1;
  311.          mifsf: Result := n3;
  312.          mifsfnl: Result := n2;
  313.          mifst:
  314.             begin
  315.                if filesystem = 'FAT' then
  316.                   Result := fstFAT
  317.                else if filesystem = 'HPFS' then
  318.                   Result := fstHPFS
  319.                else if filesystem = 'NTFS' then
  320.                   Result := fstNTFS
  321.                else
  322.                   Result := fstUnknown;
  323.             end;
  324.       else
  325.          Result := -1;
  326.       end;
  327.    end;
  328. end;
  329.  
  330. {Graphiks}
  331.  
  332. procedure CreateColorArray(Color1, Color2 : TColor; Steps:Integer; var Colors:TColorsArray);
  333. var
  334.    BeginRGBValue: array[0..2] of Byte;
  335.    RGBDifference: array[0..2] of integer;
  336.  
  337.    I: Integer;
  338.    Red: Byte;
  339.    Green: Byte;
  340.    Blue: Byte;
  341. begin
  342.    SetLength(Colors, 0);
  343.    SetLength(Colors, Steps);
  344.  
  345.    BeginRGBValue[0] := GetRValue(ColorToRGB(Color1)) ;
  346.    BeginRGBValue[1] := GetGValue(ColorToRGB(Color1)) ;
  347.    BeginRGBValue[2] := GetBValue(ColorToRGB(Color1)) ;
  348.  
  349.    RGBDifference[0] := GetRValue(ColorToRGB(Color2)) - BeginRGBValue[0];
  350.    RGBDifference[1] := GetGValue(ColorToRGB(Color2)) - BeginRGBValue[1];
  351.    RGBDifference[2] := GetBValue(ColorToRGB(Color2)) - BeginRGBValue[2];
  352.  
  353.    for I := 0 to Steps - 1 do
  354.    begin
  355.       Red := BeginRGBValue[0] + MulDiv(I, RGBDifference[0], Steps - 1) ;
  356.       Green := BeginRGBValue[1] + MulDiv(I, RGBDifference[1], Steps - 1) ;
  357.       Blue := BeginRGBValue[2] + MulDiv(I, RGBDifference[2], Steps - 1) ;
  358.  
  359.       Colors[I] := rgb(Red, Green, Blue);
  360.    end;
  361. end;
  362.  
  363. procedure GradientFillColors(Canvas: TCanvas; Colors:TColorsArray; R:TRect);
  364. var
  365.    ColorBand: TRect; { Color band rectangular coordinates }
  366.    I: Integer; { Color band index }
  367.    Brush, OldBrush: HBrush;
  368.    wWidth, wHeight : integer;
  369.    Steps : integer;
  370. begin
  371.    ColorBand.Top := R.Top;
  372.    ColorBand.Bottom := R.Bottom;
  373.    ColorBand.Left := R.Left;
  374.  
  375.    wWidth := RectWidth(R);
  376.    wHeight := RectHeight(ColorBand);
  377.  
  378.    Steps := high(Colors);
  379.    for I := 0 to Steps-1 do
  380.    begin { iterate through the color bands }
  381.       ColorBand.Right := R.Left + MulDiv(I + 1, wWidth, Steps);
  382.  
  383.       Brush := CreateSolidBrush(Colors[I]) ;
  384.       OldBrush := SelectObject(Canvas.handle, Brush) ;
  385.       try
  386.          PatBlt(Canvas.handle, ColorBand.Left, ColorBand.Top, ColorBand.Right - ColorBand.Left, wHeight, PATCOPY) ;
  387.       finally
  388.          SelectObject(Canvas.handle, OldBrush) ;
  389.          DeleteObject(Brush) ;
  390.       end;
  391.  
  392.       ColorBand.Left := ColorBand.Right;
  393.    end; { iterate through the color bands }
  394. end;
  395.  
  396. const
  397.    FNumColors = $FF; //8-bit
  398.  
  399. type
  400.    pTRGBArray = ^TRGBArray;
  401.    TRGBArray = array[0..0] of TRGBTriple; {This syntax is as bad as C}
  402.  
  403. procedure GradientFill(Canvas: TCanvas; FBeginColor, FEndColor: TColor; R: TRect; FillStyle:TGradientFill = gfLinear) ;
  404. var
  405.   { Set up working variables }
  406.    wBeginRGBValue: array[0..2] of Byte; { Begin RGB values }
  407.    wRGBDifference: array[0..2] of integer; { Difference between begin and end }
  408.                                            { RGB values                       }
  409.    wColorBand: TRect; { Color band rectangular coordinates }
  410.    wIndex: Integer; { Color band index }
  411.    wRed: Byte; { Color band Red value }
  412.    wGreen: Byte; { Color band Green value }
  413.    wBlue: Byte; { Color band Blue value }
  414.    wBrush, wOldBrush: HBrush;
  415.    wPen, wOldPen: HPen;
  416.    wWidth, wHeight : integer;
  417.    wSteps : integer;
  418.    wAngle : Double;
  419.    wLastx, wLasty : integer;
  420.    wIncAngle : double;
  421. begin
  422.   { Extract the begin RGB values }
  423.   { Set the Red, Green and Blue colors }
  424.    wBeginRGBValue[0] := GetRValue(ColorToRGB(FBeginColor) ) ;
  425.    wBeginRGBValue[1] := GetGValue(ColorToRGB(FBeginColor) ) ;
  426.    wBeginRGBValue[2] := GetBValue(ColorToRGB(FBeginColor) ) ;
  427.   { Calculate the difference between begin and end RGB values }
  428.    wRGBDifference[0] := GetRValue(ColorToRGB(FEndColor) ) - wBeginRGBValue[0];
  429.    wRGBDifference[1] := GetGValue(ColorToRGB(FEndColor) ) - wBeginRGBValue[1];
  430.    wRGBDifference[2] := GetBValue(ColorToRGB(FEndColor) ) - wBeginRGBValue[2];
  431.  
  432.   wSteps := 0;
  433.   wHeight := 0;
  434.   wWidth := 0;
  435.   wLastx := 0;
  436.   wLasty := 0;
  437.  
  438.   case FillStyle of
  439.     gfLinear :
  440.        begin
  441.           { Calculate the color band's top and bottom coordinates }
  442.           { for Left To Right fills }
  443.            wColorBand.Top := R.Top;
  444.            wColorBand.Bottom := R.Bottom;
  445.            wColorBand.Left := R.Left;
  446.            wHeight := RectHeight(R);
  447.            wWidth := RectWidth(R);
  448.            wSteps := fNumColors;
  449.        end;
  450.     gfRectangle,
  451.     gfOval,
  452.     gfRoundRect :
  453.        begin
  454.            wHeight := RectHeight(R);
  455.            wWidth := RectWidth(R);
  456.            wSteps := lessthanint(wHeight div 2, wWidth div 2);
  457.            wColorBand := R;
  458.        end;
  459.     gfRadial :
  460.        begin
  461.            wSteps := 360;
  462.            wHeight := RectHeight(R);
  463.            wWidth := RectWidth(R);
  464.            wColorBand := R;
  465.            wLastx := (wWidth shr 1);
  466.            wLasty := (wheight shr 1);
  467.        end;
  468.   end;
  469.  
  470.   { Perform the fill }
  471.    for wIndex := 0 to wSteps - 1 do
  472.    begin { iterate through the color bands }
  473.     { Calculate the color band's color }
  474.       if FillStyle <> gfRadial then
  475.       begin
  476.          wRed := wBeginRGBValue[0] + MulDiv(wIndex, wRGBDifference[0], wSteps - 1) ;
  477.          wGreen := wBeginRGBValue[1] + MulDiv(wIndex, wRGBDifference[1], wSteps - 1) ;
  478.          wBlue := wBeginRGBValue[2] + MulDiv(wIndex, wRGBDifference[2], wSteps - 1) ;
  479.       end
  480.       else
  481.       begin
  482.          if wIndex < (wSteps shr 1)-1 then
  483.          begin
  484.             wRed := wBeginRGBValue[0] + MulDiv(wIndex, wRGBDifference[0], (wSteps shr 1) - 1) ;
  485.             wGreen := wBeginRGBValue[1] + MulDiv(wIndex, wRGBDifference[1], (wSteps shr 1) - 1) ;
  486.             wBlue := wBeginRGBValue[2] + MulDiv(wIndex, wRGBDifference[2], (wSteps shr 1) - 1) ;
  487.          end
  488.          else
  489.          begin
  490.             wRed := wBeginRGBValue[0] + MulDiv(((wSteps-1) - wIndex), wRGBDifference[0], (wSteps shr 1)) ;
  491.             wGreen := wBeginRGBValue[1] + MulDiv(((wSteps-1) - wIndex), wRGBDifference[1], (wSteps shr 1)) ;
  492.             wBlue := wBeginRGBValue[2] + MulDiv(((wSteps-1) - wIndex), wRGBDifference[2], (wSteps shr 1)) ;
  493.          end;
  494.       end;
  495.  
  496.       wBrush := CreateSolidBrush(RGB(wRed, wGreen, wBlue) ) ;
  497.       wOldBrush := SelectObject(Canvas.handle, wBrush) ;
  498.       try
  499.          case FillStyle of
  500.            gfLinear :
  501.               begin
  502.                  wColorBand.Right := R.Left + MulDiv(wIndex + 1, wWidth, wSteps) ;
  503.                  PatBlt(Canvas.handle, wColorBand.Left, wColorBand.Top, wColorBand.Right - wColorBand.Left, wHeight, PATCOPY) ;
  504.                  wColorBand.Left := wColorBand.Right;
  505.               end;
  506.            gfRectangle :
  507.               begin
  508.                  wPen := CreatePen(ps_Solid, 1, RGB(wRed, wGreen, wBlue)) ;
  509.                  wOldPen := SelectObject(Canvas.handle, wPen) ;
  510.                  try
  511.                     Rectangle(Canvas.Handle, wColorBand.left, wColorBand.Top, wColorBand.right, wColorBand.Bottom);
  512.                     InflateRect(wColorBand, -1, -1);
  513.                  finally
  514.                     SelectObject(Canvas.handle, wOldPen) ;
  515.                     DeleteObject(wPen) ;
  516.                  end;
  517.               end;
  518.            gfRoundRect :
  519.               begin
  520.                  wPen := CreatePen(ps_Solid, 1, RGB(wRed, wGreen, wBlue)) ;
  521.                  wOldPen := SelectObject(Canvas.handle, wPen) ;
  522.                  try
  523.                     RoundRect(Canvas.Handle, wColorBand.left, wColorBand.Top, wColorBand.right, wColorBand.Bottom, 30, 30);
  524.                     InflateRect(wColorBand, -1, -1);
  525.                  finally
  526.                     SelectObject(Canvas.handle, wOldPen) ;
  527.                     DeleteObject(wPen) ;
  528.                  end;
  529.               end;
  530.            gfOval :
  531.               begin
  532.                  wPen := CreatePen(ps_Solid, 1, RGB(wRed, wGreen, wBlue)) ;
  533.                  wOldPen := SelectObject(Canvas.handle, wPen) ;
  534.                  try
  535.                     Ellipse(Canvas.Handle, wColorBand.left, wColorBand.Top, wColorBand.right, wColorBand.Bottom);
  536.                     InflateRect(wColorBand, -1, -1);
  537.                  finally
  538.                     SelectObject(Canvas.handle, wOldPen) ;
  539.                     DeleteObject(wPen) ;
  540.                  end;
  541.               end;
  542.            gfRadial :
  543.               begin
  544.                  wPen := CreatePen(ps_Solid, 1, RGB(wRed, wGreen, wBlue)) ;
  545.                  wOldPen := SelectObject(Canvas.handle, wPen) ;
  546.                  try
  547.                     if wIndex < wSteps then
  548.                       wincangle := 0.027
  549.                     else
  550.                       wincangle := 0;
  551.                     wAngle := (2 * Pi * ((wIndex+1) / wSteps));
  552.                     pie(Canvas.handle, 0, 0, wWidth, wHeight, Round(((wWidth shr 1)) * (1-Cos(wAngle+wIncAngle))), Round(((wheight shr 1)) * (1-Sin(wAngle+wIncAngle))), wlastx, wlasty);
  553.                     wlastx := Round(((wWidth shr 1)) * (1-Cos(wAngle)));
  554.                     wlasty := Round(((wheight shr 1)) * (1-Sin(wAngle)));
  555.                  finally
  556.                     SelectObject(Canvas.handle, wOldPen) ;
  557.                     DeleteObject(wPen) ;
  558.                  end;
  559.               end;
  560.          end;
  561.       finally
  562.          SelectObject(Canvas.handle, wOldBrush) ;
  563.          DeleteObject(wBrush) ;
  564.       end;
  565.    end; { iterate through the color bands }
  566. end; { GradientFill }
  567.  
  568. procedure RotateImage(BitmapRotated, BitmapOriginal: tbitmap; angle: integer) ;
  569. var
  570.    cosTheta: DOUBLE;
  571.    i: INTEGER;
  572.    iRotationAxis: INTEGER;
  573.    iOriginal: INTEGER;
  574.    iPrime: INTEGER;
  575.    iPrimeRotated: INTEGER;
  576.    j: INTEGER;
  577.    jRotationAxis: INTEGER;
  578.    jOriginal: INTEGER;
  579.    jPrime: INTEGER;
  580.    jPrimeRotated: INTEGER;
  581.    RowOriginal: pTRGBArray;
  582.    RowRotated: pTRGBArray;
  583.    sinTheta: DOUBLE;
  584.    Theta: DOUBLE; {radians}
  585.  
  586. begin
  587.    BitmapRotated.assign(Bitmaporiginal) ;
  588.    BitmapRotated.canvas.fillrect(rect(0, 0, bitmaprotated.width, bitmaprotated.height) ) ;
  589.    iRotationAxis := BitmapRotated.Width div 2;
  590.    jRotationAxis := BitmapRotated.Height div 2;
  591.    Theta := angle * PI / 180;
  592.    sinTheta := SIN(Theta) ;
  593.    cosTheta := COS(Theta) ;
  594.    for j := BitmapRotated.Height - 1 downto 0 do
  595.    begin
  596.       RowRotated := pTRGBArray(BitmapRotated.Scanline[j]) ;
  597.       jPrime := 2 * (j - jRotationAxis) + 1;
  598.       for i := BitmapRotated.Width - 1 downto 0 do
  599.       begin
  600.          iPrime := 2 * (i - iRotationAxis) + 1;
  601.          iPrimeRotated := ROUND(iPrime * CosTheta - jPrime * sinTheta) ;
  602.          jPrimeRotated := ROUND(iPrime * sinTheta + jPrime * cosTheta) ;
  603.          iOriginal := (iPrimeRotated - 1) div 2 + iRotationAxis;
  604.          jOriginal := (jPrimeRotated - 1) div 2 + jRotationAxis;
  605. {$R-}
  606.          if (iOriginal >= 0) and (iOriginal <= BitmapOriginal.Width - 1) and
  607.             (jOriginal >= 0) and (jOriginal <= BitmapOriginal.Height - 1) then
  608.          begin
  609.             RowOriginal := pTRGBArray(BitmapOriginal.Scanline[jOriginal]) ;
  610.             RowRotated[i].rgbtBlue := RowOriginal[iOriginal].rgbtBlue;
  611.             RowRotated[i].rgbtGreen := RowOriginal[iOriginal].rgbtGreen;
  612.             RowRotated[i].rgbtRed := RowOriginal[iOriginal].rgbtRed;
  613.          end
  614.          else
  615.          begin
  616.             RowRotated[i].rgbtBlue := 192; {assign "corner" color}
  617.             RowRotated[i].rgbtGreen := 192;
  618.             RowRotated[i].rgbtRed := 192;
  619.          end
  620. {$R+}
  621.       end
  622.    end;
  623. end;
  624.  
  625. procedure RotateText(Canvas: TCanvas; Text: string; var R: TRect; Angle: Integer) ;
  626. var
  627.    wMetric: TTextMetric;
  628.    LogFont: TLogFont;
  629.    NewFont, OldFont: TFont;
  630.    bigger: integer;
  631.    bmp1, bmp2: tbitmap;
  632.    tw, th: integer;
  633.    OldTA : integer;
  634.    NewTA : integer;
  635. begin
  636.    GetTextMetrics(Canvas.handle, wMetric) ;
  637.  
  638.    Bigger := RectDiameter(rect(0,0,canvas.textwidth(text),canvas.TextHeight(text))) ;
  639.  
  640.    if (wMetric.tmPitchAndFamily and tmpf_TrueType <> 0) then
  641.    begin
  642.       OldFont := tFont.create;
  643.       NewFont := tfont.create;
  644.       try
  645.          OldFont.assign(canvas.Font);
  646.          NewFont.assign(canvas.Font);
  647.          windows.GetObject(NewFont.Handle, SizeOf(TLogFont) , @LogFont) ;
  648.          try
  649.             LogFont.lfEscapement := Angle * 10;
  650.             LogFont.lfOrientation := Angle * 10;
  651.             NewFont.handle := CreateFontIndirect(LogFont) ;
  652.             Canvas.Font.Assign(NewFont);
  653.  
  654.             NewTA := TA_CENTER or TA_BASELINE or TA_NOUPDATECP;
  655.             OldTA := GetTextAlign(Canvas.Handle);
  656.             try
  657.                SetTextAlign(Canvas.Handle, NewTA);
  658.                TextOut(Canvas.Handle, r.Left + (bigger shr 1),  r.Top + (bigger shr 1), pchar(text), length(text));
  659.             finally
  660.                SetTextAlign(Canvas.Handle, OldTA);
  661.             end;
  662.             Canvas.Font.Assign(OldFont);
  663.          finally
  664.             windows.DeleteObject(NewFont.handle) ;
  665.          end;
  666.       finally
  667.          NewFont.free;
  668.          OldFont.free;
  669.       end;
  670.    end
  671.    else
  672.    begin
  673.       bmp1 := tbitmap.create;
  674.       try
  675.          bmp1.pixelformat := pf24bit;
  676.          bmp1.Canvas.Brush.Assign(Canvas.Brush);
  677.          bmp1.Canvas.Font.Assign(Canvas.font);
  678.  
  679.          th := bmp1.canvas.TextHeight(text) ;
  680.          tw := bmp1.canvas.textwidth(text) ;
  681.  
  682.          Bigger := RectDiameter(rect(0,0,tw,th)) ;
  683.  
  684.          bmp1.width := bigger;
  685.          bmp1.Height := bigger;
  686.  
  687.          NewTA := TA_CENTER or TA_BASELINE or TA_NOUPDATECP;
  688.          OldTA := GetTextAlign(bmp1.Canvas.Handle);
  689.          try
  690.             SetTextAlign(bmp1.Canvas.Handle, NewTA);
  691.             TextOut(bmp1.Canvas.Handle, r.left + (bigger shr 1), r.top + (bigger shr 1), pchar(text), length(text));
  692.          finally
  693.             SetTextAlign(bmp1.Canvas.Handle, OldTA);
  694.          end;
  695.  
  696.          bmp2 := tbitmap.create;
  697.          try
  698.             rotateimage(bmp2, bmp1, angle) ;
  699.             bmp2.Transparent := true;
  700.             canvas.Draw(0,0, bmp2);
  701.          finally
  702.             bmp2.free;
  703.          end;
  704.       finally
  705.          bmp1.free;
  706.       end;
  707.    end;
  708. end;
  709.  
  710. procedure ReplaceColors(var bmp: TBitmap; BackGrnd, ForeGrnd: TColor) ;
  711. var
  712.    x, y: integer;
  713.    P: PByteArray;
  714.    wColor: TColor;
  715.    wValue: integer;
  716. begin
  717.    bmp.PixelFormat := pf24bit;
  718.  
  719.    for y := 0 to bmp.height - 1 do
  720.    begin
  721.       P := bmp.ScanLine[y];
  722.       x := 0;
  723.       while x < (bmp.width * 3) do
  724.       begin
  725.          wColor := rgb(p[x + 2], p[x + 1], p[x]) ;
  726.          case wColor of
  727.             clwhite: wValue := ColorToRGB(backGrnd) ;
  728.             clBlack: wValue := ColorToRGB(ForeGrnd) ;
  729.          else
  730.             wValue := ColorToRGB(backGrnd) ;
  731.          end;
  732.          p[x] := getBValue(wValue) ;
  733.          p[x + 1] := getGValue(wValue) ;
  734.          p[x + 2] := getRvalue(wValue) ;
  735.          inc(x, 3)
  736.       end;
  737.    end;
  738. end;
  739.  
  740. procedure DrawGrayText(Canvas: TCanvas; Text: string; var R: TRect; Flags: Integer) ;
  741. var
  742.    oldStyle: TBrushStyle;
  743.    oldFontColor: TColor;
  744. begin
  745.    oldStyle := Canvas.Brush.Style;
  746.    oldFontColor := Canvas.Font.Color;
  747.    try
  748.       if flags and dt_calcRect = 0 then
  749.       begin
  750.          with Canvas do
  751.          begin
  752.             Brush.Style := bsClear;
  753.             OffsetRect(R, 1, 1) ;
  754.             Font.Color := clBtnHighlight;
  755.             DrawText(Handle, PChar(Text) , Length(Text), R, Flags) ;
  756.             OffsetRect(R, -1, -1) ;
  757.             Font.Color := clBtnShadow;
  758.             DrawText(Handle, PChar(Text) , Length(text), R, flags) ;
  759.          end;
  760.       end
  761.       else
  762.       begin
  763.          DrawText(Canvas.Handle, PChar(Text) , Length(Text), R, Flags) ;
  764.       end;
  765.       R.Bottom := r.Bottom+1;
  766.       r.Right := r.Right+1;
  767.    finally
  768.       Canvas.Brush.Style := oldStyle;
  769.       Canvas.Font.Color := oldFontColor;
  770.    end;
  771. end;
  772.  
  773. { CRC32 }
  774.  
  775. type
  776.    crc32tabletype = array[0..255] of longint;
  777.  
  778. var
  779.    fcrctable: crc32tabletype;
  780.  
  781. function crc32gen: crc32tabletype;
  782. var
  783.    crc, poly: longint;
  784.    i, j: integer;
  785.    crc32table: crc32tabletype;
  786. begin
  787.    fillchar(crc32table, sizeof(crc32table) , 0) ;
  788.    poly := longint($EDB88320) ;
  789.    for i := 0 to 255 do
  790.    begin
  791.       crc := i;
  792.       for j := 8 downto 1 do
  793.       begin
  794.          if (crc and 1) = 1 then
  795.             crc := (crc shr 1) xor poly
  796.          else
  797.             crc := crc shr 1;
  798.       end;
  799.       crc32table[i] := crc;
  800.    end;
  801.    result := crc32table;
  802. end;
  803.  
  804. function GetFileCRC32(filename: string) : longint;
  805. var
  806.    crc: longint;
  807.    bytesread, checked: integer;
  808.    buffer: array[0..10239] of byte;
  809.    fin: file;
  810. begin
  811.    assign(fin, filename) ;
  812.    filemode := 0;
  813.    reset(fin, 1) ;
  814.  
  815.    crc := longint($FFFFFFFF) ;
  816.  
  817.    while eof(fin) = false do
  818.    begin
  819.       blockread(fin, buffer, sizeof(buffer) , bytesread) ;
  820.  
  821.       checked := 0;
  822.  
  823.       while checked < bytesread do
  824.       begin
  825.          crc := ((crc shr 8) and $FFFFFF) xor fcrctable[(crc xor buffer[checked]) and $FF];
  826.          inc(checked) ;
  827.       end;
  828.    end;
  829.    close(fin) ;
  830.    result := (crc xor longint($FFFFFFFF) ) ;
  831. end;
  832.  
  833. function GetStrCRC32(Data: string) : longint;
  834. var
  835.    crc: longint;
  836.    index, datalength: integer;
  837. begin
  838.    crc := longint($FFFFFFFF) ;
  839.  
  840.    datalength := length(data) ;
  841.    index := 1;
  842.    while index <= datalength do
  843.    begin
  844.       crc := ((crc shr 8) and $FFFFFF) xor fcrctable[(crc xor byte(data[index]) ) and $FF];
  845.       inc(index) ;
  846.    end;
  847.    result := (crc xor Integer($FFFFFFFF) ) ;
  848. end;
  849.  
  850. function GetStrmCRC32(Data: TStream) : longint;
  851. var
  852.    crc: longint;
  853.    db: byte;
  854. begin
  855.    Data.Position := 0;
  856.  
  857.    crc := longint($FFFFFFFF) ;
  858.  
  859.    while data.Position < data.size do
  860.    begin
  861.       Data.ReadBuffer(db, 1) ;
  862.       crc := ((crc shr 8) and $FFFFFF) xor fcrctable[(crc xor db) and $FF];
  863.    end;
  864.    result := (crc xor longint($FFFFFFFF) ) ;
  865. end;
  866.  
  867. {Winsock functions}
  868.  
  869. function LocalIP: string;
  870. type
  871.    TaPInAddr = array[0..10] of PInAddr;
  872.    PaPInAddr = ^TaPInAddr;
  873. var
  874.    phe: PHostEnt;
  875.    pptr: PaPInAddr;
  876.    Buffer: array[0..63] of char;
  877.    I: Integer;
  878.    GInitData: TWSADATA;
  879. begin
  880.    Result := '';
  881.    WSAStartup($101, GInitData) ;
  882.    GetHostName(Buffer, SizeOf(Buffer) ) ;
  883.    phe := GetHostByName(buffer) ;
  884.    if phe = nil then Exit;
  885.    pptr := PaPInAddr(Phe^.h_addr_list) ;
  886.    I := 0;
  887.    while pptr^[I] <> nil do
  888.    begin
  889.       result := StrPas(inet_ntoa(pptr^[I]^) ) ;
  890.       Inc(I) ;
  891.    end;
  892.    WSACleanup;
  893. end;
  894.  
  895. function LocalName: string;
  896. type
  897.    TaPInAddr = array[0..10] of PInAddr;
  898.    PaPInAddr = ^TaPInAddr;
  899. var
  900.    phe: PHostEnt;
  901.    Buffer: array[0..63] of char;
  902.    GInitData: TWSADATA;
  903. begin
  904.    Result := '';
  905.    WSAStartup($101, GInitData) ;
  906.    GetHostName(Buffer, SizeOf(Buffer) ) ;
  907.    phe := GetHostByName(buffer) ;
  908.    if phe = nil then Exit;
  909.    result := StrPas(phe^.h_name) ;
  910.    WSACleanup;
  911. end;
  912.  
  913. { Strings }
  914.  
  915. function CountSections(St: string; ParseSep: char) : integer;
  916. var
  917.    iPos: LongInt;
  918. begin
  919.    result := 0;
  920.    while (st <> '') do
  921.    begin
  922.       iPos := Pos(ParseSep, st) ;
  923.       if iPos > 0 then
  924.       begin
  925.          Delete(st, 1, iPos) ;
  926.          inc(result) ;
  927.       end
  928.       else
  929.       begin
  930.          if st <> '' then
  931.          begin
  932.             inc(result) ;
  933.             st := '';
  934.          end;
  935.       end;
  936.    end;
  937. end;
  938.  
  939. function ParseSection(ParseLine: string; ParseNum: Integer; ParseSep: Char) : string;
  940. var
  941.    iPos: LongInt;
  942.    i: Integer;
  943.    tmp: string;
  944.  
  945. begin
  946.    tmp := ParseLine;
  947.    for i := 1 to ParseNum do
  948.    begin
  949.       iPos := Pos(ParseSep, tmp) ;
  950.       if iPos > 0 then
  951.       begin
  952.          if i = ParseNum then
  953.          begin
  954.             Result := Copy(tmp, 1, iPos - 1) ;
  955.             Exit;
  956.          end
  957.          else
  958.          begin
  959.             Delete(tmp, 1, iPos) ;
  960.          end;
  961.       end
  962.       else if ParseNum > i then
  963.       begin
  964.          Result := '';
  965.          Exit;
  966.       end
  967.       else
  968.       begin
  969.          Result := tmp;
  970.          Exit;
  971.       end;
  972.    end;
  973. end; { ParseSection }
  974.  
  975. function LeadingZero(Value, PadWidth: integer) : string;
  976. begin
  977.    try
  978.       result := inttostr(value) ;
  979.       while length(result) < PadWidth do
  980.          result := '0' + result;
  981.    except
  982.       result := '';
  983.    end;
  984. end;
  985.  
  986. function PadLeft(Data: string; PadWidth: integer) : string;
  987. begin
  988.    result := data;
  989.    while length(result) < PadWidth do
  990.       result := ' ' + result;
  991. end;
  992.  
  993. function PadRight(Data: string; PadWidth: integer) : string;
  994. begin
  995.    result := data;
  996.    while length(result) < PadWidth do
  997.       result := result + ' ';
  998. end;
  999.  
  1000. function StripString(StrData: string; StripChars: TrmCharSet; ReplaceChar: char) : string;
  1001. var
  1002.    loop: integer;
  1003.    wlen: integer;
  1004. begin
  1005.    result := '';
  1006.    loop := 0;
  1007.    wLen := length(StrData) ;
  1008.    while loop < wLen do
  1009.    begin
  1010.       inc(loop) ;
  1011.       if StrData[loop] in StripChars then
  1012.          result := result + ReplaceChar
  1013.       else
  1014.          result := result + StrData[loop];
  1015.    end;
  1016. end;
  1017.  
  1018. function rmDateTimeToStr(x: TDateTime) : string;
  1019. var
  1020.    y, mth, d, h, m, s, ms: word;
  1021. begin
  1022.    DecodeDate(x, y, mth, d) ;
  1023.    DecodeTime(x, h, m, s, ms) ;
  1024.    result := inttostr(y) + inttostr(mth) + inttostr(d) + inttostr(h) + inttostr(m) + inttostr(s) + inttostr(ms) ;
  1025. end;
  1026.  
  1027. function MaskStrCmp(mask, s: string) : boolean;
  1028. begin
  1029.    while mask <> '' do
  1030.    begin
  1031.       case mask[1] of
  1032.          '?':
  1033.             begin
  1034.                if s = '' then
  1035.                begin
  1036.                   result := false;
  1037.                   exit;
  1038.                end;
  1039.                delete(s, 1, 1) ;
  1040.                delete(mask, 1, 1) ;
  1041.             end;
  1042.          '*':
  1043.             begin
  1044.                while (mask <> '') and (mask[1] = '*') do
  1045.                   delete(mask, 1, 1) ;
  1046.                if (mask = '') then
  1047.                begin
  1048.                   result := true;
  1049.                   exit;
  1050.                end;
  1051.                if (mask <> '?') then
  1052.                begin
  1053.                   while (s <> '') and (s[1] <> mask[1]) do
  1054.                   begin
  1055.                      if (s = '') then
  1056.                      begin
  1057.                         result := false;
  1058.                         exit;
  1059.                      end
  1060.                      else
  1061.                         delete(s, 1, 1) ;
  1062.                   end;
  1063.                   delete(s, 1, 1) ;
  1064.                   delete(mask, 1, 1) ;
  1065.                end;
  1066.             end;
  1067.       else
  1068.          if ((s = '') and (mask <> '') ) or
  1069.             ((s <> '') and (mask = '') ) or
  1070.             (s[1] <> mask[1]) then
  1071.          begin
  1072.             result := false;
  1073.             exit;
  1074.          end;
  1075.          delete(s, 1, 1) ;
  1076.          delete(mask, 1, 1) ;
  1077.       end;
  1078.    end;
  1079.    if ((s = '') and (mask <> '') ) or
  1080.       ((s <> '') and (mask = '') ) then
  1081.       result := false
  1082.    else
  1083.       result := true;
  1084. end;
  1085.  
  1086. function Soundex(InStr: string; StandardResult: boolean = True; Precision : integer = 4) : string;
  1087. const
  1088.    Table1: array[0..25] of char = '01230120022455012623010202';
  1089.                                  { ABCDEFGHIJKLMNOPQRSTUVWXYZ }
  1090. var
  1091.    lchar: char;
  1092.    wchar: char;
  1093.    count: integer;
  1094. begin
  1095.    InStr := UpperCase(Trim(Instr)) ;
  1096.    result := '';
  1097.    count := length(instr) ;
  1098.  
  1099.    while (Instr <> '') and (count > 0) do
  1100.    begin
  1101.       if not (Instr[count] in ['A'..'Z']) then
  1102.          delete(Instr, count, 1) ;
  1103.       dec(count) ;
  1104.    end;
  1105.  
  1106.    if Instr = '' then
  1107.       exit;
  1108.  
  1109.    if (length(instr) > 1) and (instr[1] = 'P') and (instr[2] = 'H') then
  1110.    begin
  1111.       instr[1] := 'F';
  1112.       instr[2] := 'A';
  1113.    end;
  1114.  
  1115.    lChar := #0;
  1116.  
  1117.    if StandardResult then
  1118.    begin
  1119.       result := instr[1];
  1120.       lchar := instr[1];
  1121.       delete(instr, 1, 1) ;
  1122.    end;
  1123.  
  1124.    Count := 0;
  1125.    while (instr <> '') and (count < Precision) do
  1126.    begin
  1127.       if (instr[1] in ['A'..'Z']) and (instr[1] <> lchar) then
  1128.       begin
  1129.          wchar := Table1[ord(instr[1]) - 65];
  1130.          if wchar <> '0' then
  1131.          begin
  1132.             result := result + wchar;
  1133.             inc(count) ;
  1134.          end;
  1135.          lchar := instr[1];
  1136.       end;
  1137.       delete(instr, 1, 1) ;
  1138.    end;
  1139.    while length(result) < Precision do
  1140.       result := result + '0';
  1141. end;
  1142.  
  1143. { Shell }
  1144.  
  1145. const
  1146.    CLSID_ShellLink: TGUID = (D1: $00021401; D2: $0; D3: $0; D4: ($C0, $0, $0, $0, $0, $0, $0, $46) ) ;
  1147.    IID_IShellLink: TGUID = (D1: $000214EE; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46) ) ;
  1148.    IID_IPersistFile: TGUID = (D1: $0000010B; D2: $0000; D3: $0000; D4: ($C0, $00, $00, $00, $00, $00, $00, $46) ) ;
  1149.  
  1150.    ShowCommands: array[TWindowState] of Integer = (SW_SHOWNORMAL, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED) ;
  1151.  
  1152. function GetFileType(FileName: string) : string;
  1153. var
  1154.    sfi: SHFILEINFO;
  1155.    wname: string;
  1156.    wattr: DWord;
  1157.    wExt: string;
  1158. begin
  1159.    if filename = '' then
  1160.       raise exception.create('No file specified') ;
  1161.  
  1162.    result := '';
  1163.    wattr := GetFileAttributes(pchar(filename) ) ;
  1164.    if wattr = $FFFFFFFF then
  1165.    begin
  1166.       wattr := FILE_ATTRIBUTE_NORMAL;
  1167.       wname := extractfileext(filename) ;
  1168.    end
  1169.    else
  1170.       wname := filename;
  1171.  
  1172.    fillchar(sfi, sizeof(SHFILEINFO) , 0) ;
  1173.    SHGetFileInfo(pchar(wname) , wattr, sfi, sizeof(sfi) , SHGFI_USEFILEATTRIBUTES or SHGFI_TYPENAME) ;
  1174.    result := Trim(sfi.szTypeName) ;
  1175.    if result = '' then
  1176.    begin
  1177.       wExt := uppercase(extractfileext(wname) ) + ' File';
  1178.       delete(wExt, 1, 1) ;
  1179.       result := Trim(wExt) ;
  1180.    end;
  1181. end;
  1182.  
  1183. function GetFileIcon(FileName: string; SmallImage: Boolean) : TIcon;
  1184. var
  1185.    fext: string;
  1186.    sfi: SHFILEINFO;
  1187.    ShellImages: TImageList;
  1188.    wname: string;
  1189.    wattr: DWord;
  1190. begin
  1191.    result := nil;
  1192.  
  1193.    if Filename = '' then
  1194.       raise exception.create('No file specified') ;
  1195.  
  1196.    wattr := GetFileAttributes(pchar(Filename) ) ;
  1197.    if wattr = $FFFFFFFF then
  1198.    begin
  1199.       wattr := FILE_ATTRIBUTE_NORMAL;
  1200.  
  1201.       fext := extractfileext(Filename) ;
  1202.       while ansilowercase(fext) = '.lnk' do
  1203.       begin
  1204.          with ReadShortCutFile(filename) do
  1205.          begin
  1206.             fext := extractfileext(LinkName) ;
  1207.          end;
  1208.  
  1209.          if fext = '' then
  1210.             exit;
  1211.  
  1212.       end;
  1213.       wname := fext;
  1214.    end
  1215.    else
  1216.       wname := Filename;
  1217.  
  1218.    ShellImages := timagelist.create(nil) ;
  1219.    try
  1220.       ShellImages.ShareImages := true;
  1221.       fillchar(sfi, sizeof(SHFILEINFO) , 0) ;
  1222.  
  1223.       if smallImage then
  1224.          ShellImages.handle := SHGetFileInfo(pchar(wname) , wattr, sfi, sizeof(sfi) , SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_SMALLICON)
  1225.       else
  1226.          ShellImages.handle := SHGetFileInfo(pchar(wname) , wattr, sfi, sizeof(sfi) , SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_LARGEICON) ;
  1227.  
  1228.       ShellImages.GetIcon(sfi.iIcon, fIcon) ;
  1229.       result := ficon
  1230.    finally
  1231.       ShellImages.free;
  1232.    end;
  1233. end;
  1234.  
  1235. function GetFileImageIndex(Filename: string; SmallImage: boolean) : integer;
  1236. var
  1237.    fext: string;
  1238.    sfi: SHFILEINFO;
  1239.    wname: string;
  1240.    wattr: DWord;
  1241. begin
  1242.    result := -1;
  1243.  
  1244.    if Filename = '' then
  1245.       raise exception.create('No file specified') ;
  1246.  
  1247.    wattr := GetFileAttributes(pchar(Filename) ) ;
  1248.    if wattr = $FFFFFFFF then
  1249.    begin
  1250.       wattr := FILE_ATTRIBUTE_NORMAL;
  1251.  
  1252.       fext := extractfileext(Filename) ;
  1253.       while ansilowercase(fext) = '.lnk' do
  1254.       begin
  1255.          with ReadShortCutFile(filename) do
  1256.          begin
  1257.             fext := extractfileext(LinkName) ;
  1258.          end;
  1259.  
  1260.          if fext = '' then
  1261.             exit;
  1262.  
  1263.       end;
  1264.       wname := fext;
  1265.    end
  1266.    else
  1267.       wname := Filename;
  1268.  
  1269.    fillchar(sfi, sizeof(SHFILEINFO) , 0) ;
  1270.  
  1271.    if smallImage then
  1272.       SHGetFileInfo(pchar(wname) , wattr, sfi, sizeof(sfi) , SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_SMALLICON)
  1273.    else
  1274.       SHGetFileInfo(pchar(wname) , wattr, sfi, sizeof(sfi) , SHGFI_USEFILEATTRIBUTES or SHGFI_SYSICONINDEX or SHGFI_LARGEICON) ;
  1275.  
  1276.    result := sfi.iIcon;
  1277. end;
  1278.  
  1279. function GetFileImages(AImageList: TImageList; SmallImage: boolean) : boolean;
  1280. var
  1281.    sfi: SHFILEINFO;
  1282.    wname: string;
  1283. begin
  1284.   {I want all file images}
  1285.    wname := '';
  1286.    AImageList.ShareImages := true;
  1287.    fillchar(sfi, sizeof(SHFILEINFO) , 0) ;
  1288.  
  1289.    if smallImage then
  1290.       AImageList.handle := SHGetFileInfo(pchar(wname) , 0, sfi, sizeof(sfi) , SHGFI_SYSICONINDEX or SHGFI_SMALLICON)
  1291.    else
  1292.       AImageList.handle := SHGetFileInfo(pchar(wname) , 0, sfi, sizeof(sfi) , SHGFI_SYSICONINDEX or SHGFI_LARGEICON) ;
  1293.  
  1294.    Result := AImageList.handle <> 0;
  1295. end;
  1296.  
  1297. function ReadShortCutFile(filename: string) : TShortcutDetails;
  1298. var
  1299.    Str: array[0..MAX_PATH] of Char;
  1300.    Index: integer;
  1301.    ShellLink: IShellLink;
  1302.    PersistFile: IPersistFile;
  1303.    FindData: TWin32FindData;
  1304. begin
  1305.    FillChar(result, sizeof(TShortcutdetails) , 0) ;
  1306.  
  1307.    CoInitialize(nil) ;
  1308.    if Succeeded(COCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_IShellLink, ShellLink) ) then
  1309.    begin
  1310.       try
  1311.          if Succeeded(ShellLink.QueryInterface(IID_IPersistFile, PersistFile) ) then
  1312.          begin
  1313.             StringToWideChar(FileName, @Str, SizeOf(Str) ) ;
  1314.             if PersistFile.Load(@Str, STGM_READ) = NOERROR then
  1315.             begin
  1316.                ;
  1317.                ShellLink.GetArguments(Str, MAX_PATH) ;
  1318.                result.Arguments := Str;
  1319.                ShellLink.GetDescription(Str, MAX_PATH) ;
  1320.                result.Description := Str;
  1321.                ShellLink.GetHotKey(Word(result.HotKey) ) ;
  1322.                result.HotKey := KeyToShortCut(result.HotKey) ;
  1323.                ShellLink.GetIconLocation(Str, MAX_PATH, Index) ;
  1324.                result.IconFile := Str;
  1325.                result.IconIndex := Index;
  1326.                ShellLink.GetPath(Str, MAX_PATH, FindData, SLGP_UNCPRIORITY) ;
  1327.                result.LinkName := Str;
  1328.                ShellLink.GetShowCmd(Index) ;
  1329.                result.ShowCommand := GetWindowState(Index) ;
  1330.                ShellLink.GetWorkingDirectory(Str, MAX_PATH) ;
  1331.                result.WorkingDirectory := Str;
  1332.             end
  1333.             else
  1334.                raise exception.create('Error opening Shortcut.') ;
  1335.          end
  1336.          else
  1337.             raise exception.create('Error opening Shortcut.') ;
  1338.  
  1339.       finally
  1340.          CoUninitialize;
  1341.       end;
  1342.    end
  1343.    else
  1344.       raise exception.create('Error opening Shortcut.') ;
  1345. end;
  1346.  
  1347. procedure WriteShortCutFile(filename: string; Details: TShortcutDetails) ;
  1348. var
  1349.    Str: array[0..MAX_PATH] of Char;
  1350.    ShellLink: IShellLink;
  1351.    PersistFile: IPersistFile;
  1352. begin
  1353.    CoInitialize(nil) ;
  1354.    if Succeeded(COCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_IShellLink, ShellLink) ) then
  1355.    begin
  1356.       try
  1357.          if Succeeded(ShellLink.QueryInterface(IID_IPersistFile, PersistFile) ) then
  1358.          begin
  1359.             StrPCopy(@Str, Details.Arguments) ;
  1360.             ShellLink.SetArguments(Str) ;
  1361.             StrPCopy(@Str, Details.Description) ;
  1362.             ShellLink.SetDescription(Str) ;
  1363.             ShellLink.SetHotKey(ShortCutToKey(Details.HotKey) ) ;
  1364.             StrPCopy(@Str, Details.IconFile) ;
  1365.             ShellLink.SetIconLocation(Str, Details.IconIndex) ;
  1366.             StrPCopy(@Str, Details.LinkName) ;
  1367.             ShellLink.SetPath(Str) ;
  1368.             ShellLink.SetShowCmd(ShowCommands[Details.ShowCommand]) ;
  1369.             StrPCopy(@Str, Details.WorkingDirectory) ;
  1370.             ShellLink.SetWorkingDirectory(Str) ;
  1371.             StringToWideChar(FileName, @Str, SizeOf(Str) ) ;
  1372.             if not (PersistFile.Save(@Str, false) = NOERROR) then
  1373.                raise Exception.create('Error creating Shortcut.') ;
  1374.          end;
  1375.       finally
  1376.          CoUninitialize;
  1377.       end;
  1378.    end;
  1379. end;
  1380.  
  1381. { OS }
  1382.  
  1383. function WinOSVersion: TWinOSVersion;
  1384. var
  1385.    verinfo: TOSVersionInfo;
  1386. begin
  1387.    verinfo.dwOSVersionInfoSize := sizeof(TOSVersionInfo) ;
  1388.    GetVersionEX(verinfo) ;
  1389.  
  1390.    case verinfo.dwPlatformId of
  1391.       VER_PLATFORM_WIN32s:
  1392.          Result := wosWin3x;
  1393.       VER_PLATFORM_WIN32_WINDOWS:
  1394.          begin
  1395.             if ((verinfo.dwMajorVersion > 4) or
  1396.                ((verinfo.dwMajorVersion = 4) and (verinfo.dwMinorVersion >= 10) ) ) then
  1397.                Result := wosWin98
  1398.             else
  1399.                Result := wosWin95;
  1400.          end;
  1401.       VER_PLATFORM_WIN32_NT:
  1402.          begin
  1403.             if (verinfo.dwMajorVersion = 3) then
  1404.                Result := wosWinNT3x
  1405.             else if (verinfo.dwMajorVersion = 4) then
  1406.                Result := wosWinNT4x
  1407.             else if (verinfo.dwMajorVersion = 5) then
  1408.                result := wosWinNT2k
  1409.             else
  1410.                Result := wosWinNTX;
  1411.          end;
  1412.    else
  1413.       Result := wosUnknown;
  1414.    end;
  1415. end;
  1416.  
  1417. { Math Functions }
  1418.  
  1419. function IntInRange(Item, Low, High: integer) : boolean;
  1420. begin
  1421.    result := (item >= low) and (item <= high) ;
  1422. end;
  1423.  
  1424. function CompInRange(Item, Low, High: Comp) : boolean;
  1425. begin
  1426.    result := (item >= low) and (item <= high) ;
  1427. end;
  1428.  
  1429. function SetInRange(Item, Low, High: integer) : integer;
  1430. begin
  1431.    if low > high then
  1432.       raise ERangeError.Create(inttostr(low) + ' is not less than or equal to ' + inttostr(high) ) ;
  1433.  
  1434.    result := item;
  1435.  
  1436.    if item < low then
  1437.       result := low;
  1438.  
  1439.    if item > high then
  1440.       result := high;
  1441. end;
  1442.  
  1443. function GreaterThanInt(x1, x2: integer) : integer;
  1444. begin
  1445.    if x1 > x2 then
  1446.       result := x1
  1447.    else
  1448.       result := x2;
  1449. end;
  1450.  
  1451. function LessThanInt(x1, x2: integer) : integer;
  1452. begin
  1453.    if x1 < x2 then
  1454.       result := x1
  1455.    else
  1456.       result := x2;
  1457. end;
  1458.  
  1459. function GreaterThanFloat(x1, x2: Double) : Double;
  1460. begin
  1461.    if x1 > x2 then
  1462.       result := x1
  1463.    else
  1464.       result := x2;
  1465. end;
  1466.  
  1467. function LessThanFloat(x1, x2: Double) : Double;
  1468. begin
  1469.    if x1 < x2 then
  1470.       result := x1
  1471.    else
  1472.       result := x2;
  1473. end;
  1474.  
  1475. initialization
  1476.    fIcon := TIcon.create;
  1477.    fcrctable := crc32gen;
  1478.  
  1479. finalization
  1480.    fIcon.free;
  1481.  
  1482. end.
  1483.  
  1484.