home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kompon / d2345 / MSYSINFO.ZIP / Source / MiTeC_Routines.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-06-26  |  53.3 KB  |  1,844 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {             MiTeC Common Routines                     }
  5. {           version 1.3 for Delphi 3,4,5                }
  6. {                                                       }
  7. {       Copyright ⌐ 1997,2001 Michal Mutl               }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. {$INCLUDE MITEC_DEF.INC}
  12.  
  13. unit MiTeC_Routines;
  14.  
  15. interface
  16.  
  17. uses Windows, Classes, SysUtils, ShlObj;
  18.  
  19. type
  20.   TOSVersion = (osUnknown, os95, os95OSR2, os98, os98SE, osNT3, osNT4, os2K, osME, osXP);
  21.  
  22.   TDiskSign = string[2];
  23.  
  24.   TMediaType = (dtUnknown, dtNotExists, dtRemovable, dtFixed, dtRemote, dtCDROM, dtRAMDisk);
  25.  
  26.   TFileFlag = (fsCaseIsPreserved, fsCaseSensitive, fsUnicodeStoredOnDisk,
  27.                fsPersistentAcls, fsFileCompression, fsVolumeIsCompressed,
  28.                fsLongFileNames,
  29.                // following flags are valid only for Windows2000
  30.                fsEncryptedFileSystemSupport, fsObjectIDsSupport, fsReparsePointsSupport,
  31.                fsSparseFilesSupport, fsDiskQuotasSupport);
  32.   TFileFlags = set of TFileFlag;
  33.  
  34.   TDiskInfo = record
  35.     Sign: TDiskSign;
  36.     MediaType: TMediaType;
  37.     FileFlags: TFileFlags;
  38.     SectorsPerCluster,
  39.     BytesPerSector,
  40.     FreeClusters,
  41.     TotalClusters,
  42.     Serial: DWORD;
  43.     Capacity,
  44.     FreeSpace: Int64;
  45.     VolumeLabel,
  46.     SerialNumber,
  47.     FileSystem: string;
  48.   end;
  49.  
  50.   PWindow = ^TWindow;
  51.   TWindow = record
  52.     ClassName,
  53.     Text :string;
  54.     Handle,
  55.     Process,
  56.     Thread :longword;
  57.     ParentWin,
  58.     WndProc,
  59.     Instance,
  60.     ID,
  61.     UserData,
  62.     Style,
  63.     ExStyle :longint;
  64.     Rect,
  65.     ClientRect :TRect;
  66.     Atom,
  67.     ClassBytes,
  68.     WinBytes,
  69.     ClassWndProc,
  70.     ClassInstance,
  71.     Background,
  72.     Cursor,
  73.     Icon,
  74.     ClassStyle :longword;
  75.     Styles,
  76.     ExStyles,
  77.     ClassStyles :tstringlist;
  78.     Visible :boolean;
  79.   end;
  80.  
  81.   CharSet = set of char;
  82.  
  83.   TFileInfo = record
  84.     Name: string;
  85.     FileType: string;
  86.     Size :DWORD;
  87.     Created,
  88.     Accessed,
  89.     Modified :TDateTime;
  90.     Attributes :DWORD;
  91.     BinaryType: string;
  92.     IconHandle: THandle;
  93.   end;
  94.  
  95. const
  96.   allFilter = 'All Files'#0'*.*'#0#0;
  97.   ofnTitle = 'Select file';
  98.  
  99. function GetErrorMessage(ErrorCode: integer): string;
  100. function GetUser :string;
  101. function GetMachine :string;
  102. function GetOS :TOSVersion;
  103. function ReadRegInfo(ARoot :hkey; AKey, AValue :string) :string;
  104. function ReadVerInfo(const fn :string; var Desc :string) :string;
  105. function GetClassDevices(AStartKey,AClassName,AValueName :string; var AResult :TStrings) :string;
  106. procedure GetEnvironment(var EnvList :tstrings);
  107. function GetWinDir :string;
  108. function GetSysDir :string;
  109. function GetTempDir :string;
  110. function GetWinSysDir: string;
  111. function GetProfilePath: string;
  112. function GetWindowInfo(wh: hwnd): PWindow;
  113. function DisplayPropDialog(const Handle: HWND; const FileName: string): Boolean;
  114. function ResolveLink(const LinkFile: TFileName; var FileName, Arguments: string): HRESULT;
  115. function GetSpecialFolder(Handle: Hwnd; nFolder: Integer): string;
  116. function KillProcess(APID: integer): Boolean;
  117. function GetFontRes: DWORD;
  118. function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile,ErrMsg :string): Boolean;
  119.  
  120. function ExpandEnvVars(ASource: string): string;
  121. procedure StringsToRep(sl: TStrings; CountKwd,ItemKwd: string; var Report: TStringlist);
  122. function ReplaceStr(ASource,AFind,AReplace :string) :string;
  123. function ReverseStr(S: string): string;
  124. function FormatSeconds(TotalSeconds :comp; WholeSecondsOnly, DisplayAll, DTFormat :Boolean) :string;
  125. function SubStr(ASource,AFind,AReplace :string) :string;
  126. function GetStrFromBuf(var Buffer: PChar): string;
  127. function TrimAll(ASource: string): string;
  128. function BoolToStr(AValue, AVerbose: Boolean): string;
  129. function StrToBool(ASource: string): Boolean;
  130. procedure AddWord(var ADest :string; const AWord,ADelimiter: string);
  131. function GetDelimitedText(AList: TStrings; ADelimiter: string): string;
  132. procedure SetDelimitedText(ASource: string; ADelimiter: string; var AList: TStringList);
  133. function FitStr(const ASource, AEllipsis :string; ALength :integer) :string;
  134. function GetToken(s, adelimiter :string; index :integer) :string;
  135. procedure SetToken(adelimiter, newvalue :string; index :integer; var s :string);
  136. function  ExtractWord(N: Byte; S: String; WordDelims: CharSet): string;
  137. function TestByMask(const S, Mask: string; MaskChar: Char): Boolean;
  138. function UniPath(Path :string; RemoveBackslash :boolean) :string;
  139.  
  140. function UTCToDateTime(UTC: DWORD): TDateTime;
  141. function FileTimeToDateTimeStr(FileTime: TFileTime): string;
  142. function FiletimeToDateTime(FT: FILETIME): TDateTime;
  143. function IsLeapYear(Year: Word): Boolean;
  144. function DaysInMonth(const DT: TDateTime): Byte;
  145. function DayOfMonth2Date(year,month,weekInMonth,dayInWeek: word): TDateTime;
  146. function DSTDate2Date(dstDate: TSystemTime; year: word): TDateTime;
  147.  
  148. procedure GetFileInfo(const AFilename: string; var AFileInfo: TFileInfo);
  149. function ExtractName(const AFilename: string): string;
  150. function HasAttr(const AFileName: string; AAttr: Word): Boolean;
  151. function DirExists(const ADir: string): Boolean;
  152. function GetBinType(const AFilename :string) :string;
  153. function ExtractUNCFilename(ASource :string) :string;
  154. function FileCopy(const AFileName, ADestName: string): boolean;
  155. function FileMove(const AFileName, ADestName: string): boolean;
  156. function GetMediaPresent(Value: TDiskSign) :Boolean;
  157. function GetDiskInfo(Value: TDiskSign): TDiskInfo;
  158. function GetMediaTypeStr(dt: TMediaType) :string;
  159. function GetAvailDisks :string;
  160. procedure GetCDs(cds :tstrings);
  161. function GetOpenFileDlg(AHandle: THandle; var FileName: string;
  162.                          AOpenDlg: Boolean;
  163.                          AFilter,
  164.                          ADir,
  165.                          ATitle: string): Boolean;
  166.  
  167. function OpenMailSlot(Const Server, Slot : String): THandle;
  168. function SendToMailSlot(Const Server, Slot, Mail : String) : Boolean;
  169. function SendToWinpopup(Server, Reciever, Sender, Msg : String) : Boolean;
  170.  
  171. function IsBitOn(Value: Integer; Bit: Byte): Boolean;
  172. function EncodeBase (I: Int64; Base: Byte): string;
  173.  
  174. var
  175.   OSVersion, ClassKey: string;
  176.   IsNT,Is95,Is98,Is2K,IsOSR2,IsSE,IsME,IsXP: Boolean;
  177.   Profilepath, WindowsUser, MachineName: string;
  178.   OS: TOSVersion;
  179.  
  180. const
  181.   DescValue = 'DriverDesc';
  182.  
  183.   CSIDL_COMMON_ALTSTARTUP         = $001e;
  184.   CSIDL_COMMON_FAVORITES          = $001f;
  185.   CSIDL_INTERNET_CACHE            = $0020;
  186.   CSIDL_COOKIES                   = $0021;
  187.   CSIDL_HISTORY                   = $0022;
  188.   CSIDL_INTERNET                  = $0001;
  189.  
  190.   FILE_SUPPORTS_ENCRYPTION = 32;
  191.   FILE_SUPPORTS_OBJECT_IDS = 64;
  192.   FILE_SUPPORTS_REPARSE_POINTS = 128;
  193.   FILE_SUPPORTS_SPARSE_FILES = 256;
  194.   FILE_VOLUME_QUOTAS = 512;
  195.  
  196.   MAXSIZE = 260;
  197.  
  198.  
  199.  
  200. implementation
  201.  
  202. uses
  203.   Registry, ShellAPI, ActiveX, Messages, Math, CommDlg;
  204.  
  205. var
  206.   ofn: TOpenFilename;
  207.   buffer: array [0..MAXSIZE - 1] of Char;  
  208.  
  209. const
  210.    wpSlot = 'messngr';
  211.  
  212. function GetErrorMessage(ErrorCode: integer): string;
  213. const
  214.   BUFFER_SIZE = 1024;
  215. var
  216.   lpMsgBuf: Pchar;
  217.   LangID: DWORD;
  218. begin
  219.   lpMsgBuf:=AllocMem(BUFFER_SIZE);
  220.   LangID:=$409;//GetUserDefaultLangID;
  221.   FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS,
  222.                 nil,ErrorCode,LangID,lpMsgBuf,BUFFER_SIZE,nil);
  223.   Result:=StrPas(lpMsgBuf);
  224.   FreeMem(lpMsgBuf);
  225. end;
  226.  
  227. function GetOS;
  228. var
  229.   OS :TOSVersionInfo;
  230. begin
  231.   ZeroMemory(@OS,SizeOf(OS));
  232.   OS.dwOSVersionInfoSize:=SizeOf(OS);
  233.   GetVersionEx(OS);
  234.   Result:=osUnknown;
  235.   if OS.dwPlatformId=VER_PLATFORM_WIN32_NT then begin
  236.     case OS.dwMajorVersion of
  237.       3: Result:=osNT3;
  238.       4: Result:=osNT4;
  239.       5: Result:=os2K;
  240.     end;
  241.     if (OS.dwMajorVersion=5) and (OS.dwMinorVersion=1) then
  242.       Result:=osXP;
  243.   end else begin
  244.     if (OS.dwMajorVersion=4) and (OS.dwMinorVersion=0) then begin
  245.       Result:=os95;
  246.       if (Trim(OS.szCSDVersion)='B') then
  247.         Result:=os95OSR2;
  248.     end else
  249.       if (OS.dwMajorVersion=4) and (OS.dwMinorVersion=10) then begin
  250.         Result:=os98;
  251.         if (Trim(OS.szCSDVersion)='A') then
  252.           Result:=os98SE;
  253.       end else
  254.         if (OS.dwMajorVersion=4) and (OS.dwMinorVersion=90) then
  255.           Result:=osME;
  256.   end;
  257. end;
  258.  
  259. function FormatSeconds(TotalSeconds :comp; WholeSecondsOnly, DisplayAll, DTFormat :Boolean) :String;
  260. var
  261.  lcenturies,lyears,lmonths,lminutes,lhours,ldays,lweeks :word;
  262.  lSecs :double;
  263.  s :array[1..8] of string;
  264.  SecondsPerCentury :comp;
  265.  FS :string;
  266. begin
  267.   if WholeSecondsOnly then
  268.     FS:='%.0f'
  269.   else
  270.     FS:='%.2f';
  271.   SecondsPerCentury:=36550 * 24;
  272.   SecondsPerCentury:= SecondsPerCentury * 3600;
  273.   lcenturies:=Trunc(TotalSeconds / SecondsPerCentury);
  274.   TotalSeconds:=TotalSeconds-(lcenturies * SecondsPerCentury);
  275.   lyears:=Trunc(TotalSeconds / (365.5 * 24 * 3600));
  276.   TotalSeconds:=TotalSeconds-(lyears * (365.5 * 24 * 3600));
  277.   lmonths:=Trunc(TotalSeconds / (31 * 24 * 3600));
  278.   TotalSeconds:=TotalSeconds-(lmonths * (31 * 24 * 3600));
  279.   lweeks:=Trunc(TotalSeconds / (7 * 24 * 3600));
  280.   TotalSeconds:=TotalSeconds-(lweeks * (7 * 24 * 3600));
  281.   ldays:=Trunc(TotalSeconds / (24 * 3600));
  282.   TotalSeconds:=TotalSeconds-(ldays * (24 * 3600));
  283.   lhours:=Trunc(TotalSeconds / 3600);
  284.   TotalSeconds:=TotalSeconds-(lhours * 3600);
  285.   lminutes:=Trunc(TotalSeconds / 60);
  286.   TotalSeconds:=TotalSeconds-(lminutes * 60);
  287.   If WholeSecondsOnly then
  288.     lsecs:=Trunc(TotalSeconds)
  289.   else
  290.     lsecs:=TotalSeconds;
  291.   if lCenturies=1 then
  292.     s[1]:=' Century, '
  293.   else
  294.     s[1]:=' Centuries, ';
  295.   if lyears=1 then
  296.     s[2]:=' Year, '
  297.   else
  298.     s[2]:=' Years, ';
  299.   if lmonths=1 then
  300.     s[3]:=' Month, '
  301.   else
  302.     s[3]:=' Months, ';
  303.   if lweeks=1 then
  304.     s[4]:=' Week, '
  305.   else
  306.     s[4]:=' Weeks, ';
  307.   if ldays=1 then
  308.     s[5]:=' Day, '
  309.   else
  310.     s[5]:=' Days, ';
  311.   if lhours=1 then
  312.     s[6]:=' Hour, '
  313.   else
  314.     s[6]:=' Hours, ';
  315.   if lminutes=1 then
  316.     s[7]:=' Minute, '
  317.   else
  318.     s[7]:=' Minutes, ';
  319.   if lsecs=1 then
  320.     s[8]:=' Second.'
  321.   else
  322.     s[8]:=' Seconds.';
  323.   If DisplayAll then begin
  324.     if dtformat then
  325.       result:=Format('%2.2d.%2.2d.%2.2d %2.2d:%2.2d:%2.2d',
  326.                      [lyears,lmonths,ldays+lweeks*7,lhours,lminutes,round(lSecs)])
  327.     else
  328.       Result:= Format('%.0d%s%.0d%s%.0d%s%.0d%s%.0d%s%.0d%s%.0d%s' + FS + '%s',
  329.                      [lcenturies,s[1],lyears,s[2],lmonths,s[3],lweeks,s[4],ldays,s[5],lhours,s[6],lminutes,s[7],lSecs,s[8]]);
  330.  
  331.   end else begin
  332.     if dtformat then
  333.       result:=Format('%2.2d:%2.2d:%2.2d',
  334.                      [lhours,lminutes,round(lSecs)])
  335.     else begin
  336.       if lCenturies>=1 then
  337.         Result:= Format('%.0d%s%.0d%s%.0d%s%.0d%s%.0d%s%.0d%s%.0d%s' + FS + '%s',
  338.                         [lcenturies,s[1],lyears,s[2],lmonths,s[3],lweeks,s[4],ldays,s[5],lhours,s[6],lminutes,s[7],lsecs,s[8]])
  339.       else
  340.         if lyears>=1 then
  341.           Result:= Format('%.0d%s%.0d%s%.0d%s%.0d%s%.0d%s%.0d%s' + FS + '%s',
  342.                           [lyears,s[2],lmonths,s[3],lweeks,s[4],ldays,s[5],lhours,s[6],lminutes,s[7],lsecs,s[8]])
  343.       else
  344.        if lmonths>=1 then
  345.          Result:= Format('%.0d%s%.0d%s%.0d%s%.0d%s%.0d%s' + FS + '%s',
  346.                          [lmonths,s[3],lweeks,s[4],ldays,s[5],lhours,s[6],lminutes,s[7],lsecs,s[8]])
  347.        else
  348.          if lweeks>=1 then
  349.            Result:= Format('%.0d%s%.0d%s%.0d%s%.0d%s' + FS + '%s',
  350.                            [lweeks,s[4],ldays,s[5],lhours,s[6],lminutes,s[7],lsecs,s[8]])
  351.          else
  352.            if ldays>=1 then
  353.              Result:= Format('%.0d%s%.0d%s%.0d%s' + FS + '%s',
  354.                              [ldays,s[5],lhours,s[6],lminutes,s[7],lsecs,s[8]])
  355.            else
  356.              if lhours>=1 then
  357.                Result:= Format('%.0d%s%.0d%s' + FS + '%s',
  358.                                [lhours,s[6],lminutes,s[7],lsecs,s[8]])
  359.              else
  360.                if lminutes>=1 then
  361.                  Result:= Format('%.0d%s' + FS + '%s',[lminutes,s[7],lsecs,s[8]])
  362.                else
  363.                  Result:= Format(FS + '%s',[lsecs,s[8]]);
  364.     end;
  365.   end;
  366. end;
  367.  
  368. function ReadRegInfo(ARoot :hkey; AKey, AValue :string) :string;
  369. begin
  370.   with TRegistry.create do begin
  371.     result:='';
  372.     rootkey:=aroot;
  373.     if keyexists(akey) then begin
  374.       OpenKey(akey,false);
  375.       if ValueExists(avalue) then begin
  376.         case getdatatype(avalue) of
  377.           rdstring: result:=ReadString(avalue);
  378.           rdinteger: result:=inttostr(readinteger(avalue));
  379.         end;
  380.       end;
  381.       closekey;
  382.     end;
  383.     free;
  384.   end;
  385. end;
  386.  
  387. function ReadVerInfo(const fn :string; var Desc :string) :string;
  388. var
  389.   VersionHandle,VersionSize :dword;
  390.   PItem,PVersionInfo :pointer;
  391.   FixedFileInfo :PVSFixedFileInfo;
  392.   il :uint;
  393.   version :string;
  394.   p :array [0..MAX_PATH - 1] of char;
  395. begin
  396.   version:='';
  397.   desc:='';
  398.   result:='';
  399.   if fn<>'' then begin
  400.     strpcopy(p,fn);
  401.     versionsize:=getfileversioninfosize(p,versionhandle);
  402.     if versionsize=0 then
  403.       exit;
  404.     getMem(pversioninfo,versionsize);
  405.     try
  406.       if getfileversioninfo(p,versionhandle,versionsize,pversioninfo) then begin
  407.         if verqueryvalue(pversioninfo,'\',pointer(fixedfileinfo),il) then
  408.           version:=inttostr(hiword(fixedfileinfo^.dwfileversionms))+
  409.                    '.'+inttostr(loword(fixedfileinfo^.dwfileversionms))+
  410.                    '.'+inttostr(hiword(fixedfileinfo^.dwfileversionls))+
  411.                    '.'+inttostr(loword(fixedfileinfo^.dwfileversionls));
  412.           if verqueryvalue(pversioninfo,pchar('\StringFileInfo\040904E4\FileDescription'),pitem,il) then
  413.             desc:=pchar(pitem);
  414.       end;
  415.     finally
  416.       freeMem(pversioninfo,versionsize);
  417.       result:=version;
  418.     end;
  419.   end;
  420. end;
  421.  
  422. function GetMachine :string;
  423. var
  424.   n :dword;
  425.   buf :pchar;
  426. const
  427.   rkMachine = {HKEY_LOCAL_MACHINE\}'SYSTEM\CurrentControlSet\Control\ComputerName\ComputerName';
  428.     rvMachine = 'ComputerName';
  429. begin
  430.   n:=255;
  431.   buf:=stralloc(n);
  432.   GetComputerName(buf,n);
  433.   result:=strpas(buf);
  434.   strdispose(buf);
  435.   with TRegistry.Create do begin
  436.     rootkey:=HKEY_LOCAL_MACHINE;
  437.     if OpenKey(rkMachine,false) then begin
  438.       if ValueExists(rvMachine) then
  439.         result:=ReadString(rvMachine);
  440.       closekey;
  441.     end;
  442.     free;
  443.   end;
  444. end;
  445.  
  446. function GetUser :string;
  447. var
  448.   n :dword;
  449.   buf :pchar;
  450. begin
  451.   n:=255;
  452.   buf:=stralloc(n);
  453.   GetUserName(buf,n);
  454.   result:=strpas(buf);
  455.   strdispose(buf);
  456. end;
  457.  
  458. function GetClassDevices(AStartKey,AClassName,AValueName :string; var AResult :TStrings) :string;
  459. var
  460.   i,j :integer;
  461.   sl :TStringList;
  462.   s,v,rclass :string;
  463. const
  464.   rvGUID = 'ClassGUID';
  465.   rvClass = 'Class';
  466.   rvLink = 'Link';
  467. begin
  468.   Result:='';
  469.   AResult.Clear;
  470.   with TRegistry.Create do begin
  471.     RootKey:=HKEY_LOCAL_MACHINE;
  472.     if OpenKey(AStartKey,false) then begin
  473.       sl:=TStringList.Create;
  474.       GetKeyNames(sl);
  475.       CloseKey;
  476.       for i:=0 to sl.Count-1 do
  477.         if OpenKey(AStartKey+'\'+sl[i],false) then begin
  478.           if ValueExists(rvClass) then begin
  479.             rclass:=UpperCase(ReadString(rvClass));
  480.             if rclass=UpperCase(AClassName) then begin
  481.               if not IsNT then begin
  482.                 s:=UpperCase(ReadString(rvLink));
  483.                 CloseKey;
  484.                 if not OpenKey(AStartKey+'\'+s,False) then
  485.                   Exit;
  486.               end else
  487.                 s:=sl[i];
  488.               Result:=s;
  489.               GetKeyNames(sl);
  490.               CloseKey;
  491.               for j:=0 to sl.count-1 do
  492.                 if OpenKey(AStartKey+'\'+s+'\'+sl[j],false) then begin
  493.                   if ValueExists(AValueName) then begin
  494.                     v:=ReadString(AValueName);
  495.                     if AResult.IndexOf(v)=-1 then
  496.                       AResult.Add(v);
  497.                   end;
  498.                   CloseKey;
  499.                 end;
  500.                 Break;
  501.             end;
  502.           end;
  503.           CloseKey;
  504.         end;
  505.       sl.free;
  506.     end;
  507.     free;
  508.   end;
  509. end;
  510.  
  511. procedure GetEnvironment(var EnvList :tstrings);
  512. var
  513.   c,i :dword;
  514.   b :pchar;
  515.   s :string;
  516. begin
  517.   EnvList.Clear;
  518.   c:=4096;
  519.   b:=GetEnvironmentStrings;
  520.   i:=0;
  521.   s:='';
  522.   while i<c do begin
  523.     if b[i]<>#0 then
  524.       s:=s+b[i]
  525.     else begin
  526.       if s='' then
  527.         break;
  528.       EnvList.Add(s);
  529.       s:='';
  530.     end;
  531.     inc(i);
  532.   end;
  533.   FreeEnvironmentStrings(b);
  534. end;
  535.  
  536. function GetWinSysDir: string;
  537. var
  538.   n: integer;
  539.   p: PChar;
  540. begin
  541.   n:=MAX_PATH;
  542.   p:=stralloc(n);
  543.   getwindowsdirectory(p,n);
  544.   result:=strpas(p)+';';
  545.   getsystemdirectory(p,n);
  546.   Result:=Result+strpas(p)+';';
  547. end;
  548.  
  549. function GetStrFromBuf;
  550. var
  551.   i,j :integer;
  552. begin
  553.   result:='';
  554.   j:=0;
  555.   i:=0;
  556.   repeat
  557.     if buffer[i]<>#0 then begin
  558.       result:=result+buffer[i];
  559.       j:=0;
  560.     end else
  561.       inc(j);
  562.     inc(i);
  563.   until j>1;
  564. end;
  565.  
  566. function GetWindowInfo(wh: hwnd): PWindow;
  567. var
  568.   cn,wn :pchar;
  569.   n, wpid,tid :longword;
  570. begin
  571.   n:=255;
  572.   wn:=stralloc(n);
  573.   cn:=stralloc(n);
  574.   tid:=GetWindowThreadProcessId(wh,@wpid);
  575.   getclassname(wh,cn,n);
  576.   getwindowtext(wh,wn,n);
  577.   new(result);
  578.   result^.ClassName:=strpas(cn);
  579.   result^.Text:=strpas(wn);
  580.   result^.Handle:=wh;
  581.   result^.Process:=wpid;
  582.   result^.Thread:=tid;
  583.   result^.ParentWin:=getwindowlong(wh,GWL_HWNDPARENT);
  584.   result^.WndProc:=getwindowlong(wh,GWL_WNDPROC);
  585.   result^.Instance:=getwindowlong(wh,GWL_HINSTANCE);
  586.   result^.ID:=getwindowlong(wh,GWL_ID);
  587.   result^.UserData:=getwindowlong(wh,GWL_USERDATA);
  588.   result^.Style:=getwindowlong(wh,GWL_STYLE);
  589.   result^.ExStyle:=getwindowlong(wh,GWL_EXSTYLE);
  590.   getwindowrect(wh,result^.Rect);
  591.   getclientrect(wh,result^.ClientRect);
  592.   result^.Atom:=getclasslong(wh,GCW_ATOM);
  593.   result^.ClassBytes:=getclasslong(wh,GCL_CBCLSEXTRA);
  594.   result^.WinBytes:=getclasslong(wh,GCL_CBWNDEXTRA);
  595.   result^.ClassWndProc:=getclasslong(wh,GCL_WNDPROC);
  596.   result^.ClassInstance:=getclasslong(wh,GCL_HMODULE);
  597.   result^.Background:=getclasslong(wh,GCL_HBRBACKGROUND);
  598.   result^.Cursor:=getclasslong(wh,GCL_HCURSOR);
  599.   result^.Icon:=getclasslong(wh,GCL_HICON);
  600.   result^.ClassStyle:=getclasslong(wh,GCL_STYLE);
  601.   result^.Styles:=tstringlist.create;
  602.   result^.visible:=iswindowvisible(wh);
  603.   if not(result^.ExStyle and WS_BORDER=0) then
  604.     result^.Styles.add('WS_BORDER');
  605.   if not(result^.Style and WS_CHILD=0) then
  606.     result^.Styles.add('WS_CHILD');
  607.   if not(result^.Style and WS_CLIPCHILDREN=0) then
  608.     result^.Styles.add('WS_CLIPCHILDREN');
  609.   if not(result^.Style and WS_CLIPSIBLINGS=0) then
  610.     result^.Styles.add('WS_CLIPSIBLINGS');
  611.   if not(result^.Style and WS_DISABLED=0) then
  612.     result^.Styles.add('WS_DISABLED');
  613.   if not(result^.Style and WS_DLGFRAME=0) then
  614.     result^.Styles.add('WS_DLGFRAME');
  615.   if not(result^.Style and WS_GROUP=0) then
  616.     result^.Styles.add('WS_GROUP');
  617.   if not(result^.Style and WS_HSCROLL=0) then
  618.     result^.Styles.add('WS_HSCROLL');
  619.   if not(result^.Style and WS_MAXIMIZE=0) then
  620.     result^.Styles.add('WS_MAXIMIZE');
  621.   if not(result^.Style and WS_MAXIMIZEBOX=0) then
  622.     result^.Styles.add('WS_MAXIMIZEBOX');
  623.   if not(result^.Style and WS_MINIMIZE=0) then
  624.     result^.Styles.add('WS_MINIMIZE');
  625.   if not(result^.Style and WS_MINIMIZEBOX=0) then
  626.     result^.Styles.add('WS_MINIMIZEBOX');
  627.   if not(result^.Style and WS_OVERLAPPED=0) then
  628.     result^.Styles.add('WS_OVERLAPPED');
  629.   if not(result^.Style and WS_POPUP=0) then
  630.     result^.Styles.add('WS_POPUP');
  631.   if not(result^.Style and WS_SYSMENU=0) then
  632.     result^.Styles.add('WS_SYSMENU');
  633.   if not(result^.Style and WS_TABSTOP=0) then
  634.     result^.Styles.add('WS_TABSTOP');
  635.   if not(result^.Style and WS_THICKFRAME=0) then
  636.     result^.Styles.add('WS_THICKFRAME');
  637.   if not(result^.Style and WS_VISIBLE=0) then
  638.     result^.Styles.add('WS_VISIBLE');
  639.   if not(result^.Style and WS_VSCROLL=0) then
  640.     result^.Styles.add('WS_VSCROLL');
  641.   result^.ExStyles:=tstringlist.create;
  642.   if not(result^.ExStyle and WS_EX_ACCEPTFILES=0) then
  643.     result^.ExStyles.add('WS_EX_ACCEPTFILES');
  644.   if not(result^.ExStyle and WS_EX_DLGMODALFRAME=0) then
  645.     result^.ExStyles.add('WS_EX_DLGMODALFRAME');
  646.   if not(result^.ExStyle and WS_EX_NOPARENTNOTIFY=0) then
  647.     result^.ExStyles.add('WS_EX_NOPARENTNOTIFY');
  648.   if not(result^.ExStyle and WS_EX_TOPMOST=0) then
  649.     result^.ExStyles.add('WS_EX_TOPMOST');
  650.   if not(result^.ExStyle and WS_EX_TRANSPARENT=0) then
  651.     result^.ExStyles.add('WS_EX_TRANSPARENT');
  652.   if not(result^.ExStyle and WS_EX_MDICHILD=0) then
  653.     result^.ExStyles.add('WS_EX_MDICHILD');
  654.   if not(result^.ExStyle and WS_EX_TOOLWINDOW=0) then
  655.     result^.ExStyles.add('WS_EX_TOOLWINDOW');
  656.   if not(result^.ExStyle and WS_EX_WINDOWEDGE=0) then
  657.     result^.ExStyles.add('WS_EX_WINDOWEDGE');
  658.   if not(result^.ExStyle and WS_EX_CLIENTEDGE =0) then
  659.     result^.ExStyles.add('WS_EX_CLIENTEDGE');
  660.   if not(result^.ExStyle and WS_EX_CONTEXTHELP=0) then
  661.     result^.ExStyles.add('WS_EX_CONTEXTHELP');
  662.   if not(result^.ExStyle and WS_EX_RIGHT=0) then
  663.     result^.ExStyles.add('WS_EX_RIGHT')
  664.   else
  665.     result^.ExStyles.add('WS_EX_LEFT');
  666.   if not(result^.ExStyle and WS_EX_RTLREADING=0) then
  667.     result^.ExStyles.add('WS_EX_RTLREADING')
  668.   else
  669.     result^.ExStyles.add('WS_EX_LTRREADING');
  670.   if not(result^.ExStyle and WS_EX_LEFTSCROLLBAR=0) then
  671.     result^.ExStyles.add('WS_EX_LEFTSCROLLBAR')
  672.   else
  673.     result^.ExStyles.add('WS_EX_RIGHTSCROLLBAR');
  674.   if not(result^.ExStyle and WS_EX_CONTROLPARENT=0) then
  675.     result^.ExStyles.add('WS_EX_CONTROLPARENT');
  676.   if not(result^.ExStyle and WS_EX_STATICEDGE =0) then
  677.     result^.ExStyles.add('WS_EX_STATICEDGE');
  678.   if not(result^.ExStyle and WS_EX_APPWINDOW=0) then
  679.     result^.ExStyles.add('WS_EX_APPWINDOW');
  680.   result^.ClassStyles:=tstringlist.create;
  681.   if not(result^.ClassStyle and CS_BYTEALIGNCLIENT=0) then
  682.     result^.ClassStyles.add('CS_BYTEALIGNCLIENT');
  683.   if not(result^.ClassStyle and CS_VREDRAW=0) then
  684.     result^.ClassStyles.add('CS_VREDRAW');
  685.   if not(result^.ClassStyle and CS_HREDRAW=0) then
  686.     result^.ClassStyles.add('CS_HREDRAW');
  687.   if not(result^.ClassStyle and CS_KEYCVTWINDOW=0) then
  688.     result^.ClassStyles.add('CS_KEYCVTWINDOW');
  689.   if not(result^.ClassStyle and CS_DBLCLKS=0) then
  690.     result^.ClassStyles.add('CS_DBLCLKS');
  691.   if not(result^.ClassStyle and CS_OWNDC=0) then
  692.     result^.ClassStyles.add('CS_OWNDC');
  693.   if not(result^.ClassStyle and CS_CLASSDC=0) then
  694.     result^.ClassStyles.add('CS_CLASSDC');
  695.   if not(result^.ClassStyle and CS_PARENTDC=0) then
  696.     result^.ClassStyles.add('CS_PARENTDC');
  697.   if not(result^.ClassStyle and CS_NOKEYCVT=0) then
  698.     result^.ClassStyles.add('CS_NOKEYCVT');
  699.   if not(result^.ClassStyle and CS_NOCLOSE=0) then
  700.     result^.ClassStyles.add('CS_NOCLOSE');
  701.   if not(result^.ClassStyle and CS_SAVEBITS=0) then
  702.     result^.ClassStyles.add('CS_SAVEBITS');
  703.   if not(result^.ClassStyle and CS_BYTEALIGNWINDOW=0) then
  704.     result^.ClassStyles.add('CS_BYTEALIGNWINDOW');
  705.   if not(result^.ClassStyle and CS_GLOBALCLASS=0) then
  706.     result^.ClassStyles.add('CS_GLOBALCLASS');
  707.   strdispose(wn);
  708.   strdispose(cn);
  709. end;
  710.  
  711. function ReplaceStr;
  712. var
  713.   p :integer;
  714. begin
  715.   result:='';
  716.   p:=pos(uppercase(AFind),uppercase(ASource));
  717.   while p>0 do begin
  718.     result:=result+Copy(ASource,1,p-1)+AReplace;
  719.     Delete(ASource,1,p+Length(AFind)-1);
  720.     p:=pos(uppercase(AFind),uppercase(ASource));
  721.   end;
  722.   Result:=Result+ASource;
  723. end;
  724.  
  725. function DisplayPropDialog(const Handle: HWND; const FileName: string): Boolean;
  726. var
  727.   Info: TShellExecuteInfo;
  728. begin
  729.   FillChar(Info,SizeOf(Info),#0);
  730.   with Info do begin
  731.     cbSize:=SizeOf(Info);
  732.     lpFile:=PChar(FileName);
  733.     nShow:=SW_SHOW;
  734.     fMask:=SEE_MASK_INVOKEIDLIST;
  735.     Wnd:=Handle;
  736.     lpVerb:=PChar('properties');
  737.   end;
  738.   Result:=ShellExecuteEx(@Info);
  739. end;
  740.  
  741. procedure StringsToRep(sl: TStrings; CountKwd,ItemKwd: string; var Report: TStringlist);
  742. var
  743.   i: integer;
  744. begin
  745.   with Report do begin
  746.     Add(Format('%s=%d',[CountKwd,sl.Count]));
  747.     for i:=0 to sl.Count-1 do
  748.       Add(Format('%s%d=%s',[ItemKwd,i+1,sl[i]]));
  749.   end;
  750. end;
  751.  
  752. function ResolveLink(const LinkFile: TFileName; var FileName,Arguments: string): HRESULT;
  753. var
  754.   psl: IShellLink;
  755.   WLinkFile: array [0..MAX_PATH] of WideChar;
  756.   wfd: TWIN32FINDDATA;
  757.   ppf: IPersistFile;
  758. begin
  759.   pointer(psl):=nil;
  760.   pointer(ppf):=nil;
  761.   Result:=CoInitialize(nil);
  762.   if Succeeded(Result) then begin
  763.     Result:=CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,IShellLink,psl);
  764.     if Succeeded(Result) then begin
  765.       Result:=psl.QueryInterface(IPersistFile,ppf);
  766.       if Succeeded(Result) then begin
  767.         StringToWideChar(LinkFile,WLinkFile,SizeOf(WLinkFile)-1);
  768.         Result:=ppf.Load(WLinkFile,STGM_READ);
  769.         if Succeeded(Result) then begin
  770.           Result:=psl.Resolve(0,SLR_NO_UI);
  771.           if Succeeded(Result) then begin
  772.             SetLength(FileName,MAX_PATH);
  773.             SetLength(Arguments,255);
  774.             Result:=psl.GetPath(PChar(FileName),MAX_PATH,wfd,SLGP_UNCPRIORITY);
  775.             if Succeeded(Result) then begin
  776.               SetLength(FileName,Length(PChar(FileName)));
  777.               Result:=psl.GetArguments(PChar(Arguments),255);
  778.               if Succeeded(Result) then
  779.                 SetLength(Arguments,Length(PChar(Arguments)));
  780.             end;
  781.           end;
  782.         end;
  783.         ppf._Release;
  784.       end;
  785.       psl._Release;
  786.     end;
  787.     CoUnInitialize;
  788.   end;
  789.   pointer(psl):=nil;
  790.   pointer(ppf):=nil;
  791. end;
  792.  
  793. function GetSpecialFolder(Handle: Hwnd; nFolder: Integer): string;
  794. var
  795.   PIDL: PItemIDList;
  796.   Path: LPSTR;
  797. begin
  798.   Result:='';
  799.   Path:=StrAlloc(MAX_PATH);
  800.   SHGetSpecialFolderLocation(Handle, nFolder, PIDL);
  801.   if SHGetPathFromIDList(PIDL, Path) then
  802.     Result:=StrPas(Path);
  803.   StrDispose(Path);
  804. end;
  805.  
  806. function ReverseStr(S: string): string;
  807. var
  808.   l,i: integer;
  809. begin
  810.   l:=Length(s);
  811.   Result:='';
  812.   for i:=0 to l-1 do
  813.     Result:=Result+s[l-i];
  814. end;
  815.  
  816. function GetMediaPresent(Value: TDiskSign) :Boolean;
  817. var
  818.   ErrorMode: Word;
  819.   bufRoot :pchar;
  820.   a,b,c,d :dword;
  821. begin
  822.   bufRoot:=stralloc(255);
  823.   strpcopy(bufRoot,Value+'\');
  824.   ErrorMode:=SetErrorMode(SEM_FailCriticalErrors);
  825.   try
  826.     try
  827.       result:=GetDiskFreeSpace(bufRoot,a,b,c,d);
  828.     except
  829.       result:=False;
  830.     end;
  831.   finally
  832.     strdispose(bufroot);
  833.     SetErrorMode(ErrorMode);
  834.   end;
  835. end;
  836.  
  837. function GetDiskInfo(Value: TDiskSign): TDiskInfo;
  838. var
  839.   BPS,TC,FC,SPC :integer;
  840.   T,F :TLargeInteger;
  841.   TF :PLargeInteger;
  842.   bufRoot, bufVolumeLabel, bufFileSystem :pchar;
  843.   MCL,Size,Flags :DWORD;
  844.   s :string;
  845.   {$IFNDEF D4PLUS}
  846.   h :THandle;
  847.   GetDiskFreeSpaceEx :function (lpDirectoryName: PChar;
  848.                                 var lpFreeBytesAvailableToCaller,
  849.                                     lpTotalNumberOfBytes;
  850.                                 lpTotalNumberOfFreeBytes: PLargeInteger): BOOL; stdcall;
  851.   {$ENDIF}
  852.  
  853. begin
  854.   with Result do begin
  855.     Sign:=Value;
  856.     Size:=255;
  857.     bufRoot:=AllocMem(Size);
  858.     strpcopy(bufRoot,Value+'\');
  859.     case GetDriveType(bufRoot) of
  860.       DRIVE_UNKNOWN     :MediaType:=dtUnknown;
  861.       DRIVE_NO_ROOT_DIR :MediaType:=dtNotExists;
  862.       DRIVE_REMOVABLE   :MediaType:=dtRemovable;
  863.       DRIVE_FIXED       :MediaType:=dtFixed;
  864.       DRIVE_REMOTE      :MediaType:=dtRemote;
  865.       DRIVE_CDROM       :MediaType:=dtCDROM;
  866.       DRIVE_RAMDISK     :MediaType:=dtRAMDisk;
  867.     end;
  868.     FileFlags:=[];
  869.     if GetMediaPresent(Value) then begin
  870.       GetDiskFreeSpace(bufRoot,SectorsPerCluster,BytesPerSector,FreeClusters,TotalClusters);
  871.       try
  872.         new(TF);
  873.         {$IFDEF D4PLUS}
  874.         SysUtils.GetDiskFreeSpaceEx(bufRoot,F,T,TF);
  875.         Capacity:=T;
  876.         FreeSpace:=F;
  877.         {$ELSE}
  878.         GetDiskFreeSpaceEx:=nil;
  879.         h:=LoadLibrary('KERNEL32.DLL');
  880.         if h>0 then
  881.           GetDiskFreeSpaceEx:=GetProcAddress(h,'GetDiskFreeSpaceExA');
  882.         if assigned(GetDiskFreeSpaceEx) then
  883.           GetDiskFreeSpaceEx(bufRoot,F,T,TF);
  884.         Capacity:=T;
  885.         FreeSpace:=F;
  886.         FreeLibrary(h);
  887.         {$ENDIF}
  888.         dispose(TF);
  889.       except
  890.         BPS:=BytesPerSector;
  891.         TC:=TotalClusters;
  892.         FC:=FreeClusters;
  893.         SPC:=SectorsPerCluster;
  894.         {$IFDEF D4PLUS}
  895.         Capacity:=TC*SPC*BPS;
  896.         FreeSpace:=FC*SPC*BPS;
  897.         {$ELSE}
  898.         Capacity.QuadPart:=TC*SPC*BPS;
  899.         FreeSpace.QuadPart:=FC*SPC*BPS;
  900.         {$ENDIF}
  901.       end;
  902.       bufVolumeLabel:=AllocMem(Size);
  903.       bufFileSystem:=AllocMem(Size);
  904.       if GetVolumeInformation(bufRoot,bufVolumeLabel,Size,@Serial,MCL,Flags,bufFileSystem,Size) then begin;
  905.         VolumeLabel:=strpas(bufVolumeLabel);
  906.         FileSystem:=strpas(bufFileSystem);
  907.         s:=IntToHex(Serial,8);
  908.         SerialNumber:=copy(s,1,4)+'-'+copy(s,5,4);
  909.         FreeMem(bufVolumeLabel);
  910.         FreeMem(bufFileSystem);
  911.         FreeMem(bufRoot);
  912.         if Flags and FS_CASE_SENSITIVE=FS_CASE_SENSITIVE then
  913.           FileFlags:=FileFlags+[fsCaseSensitive];
  914.         if Flags and FS_CASE_IS_PRESERVED=FS_CASE_IS_PRESERVED then
  915.           FileFlags:=FileFlags+[fsCaseIsPreserved];
  916.         if Flags and FS_UNICODE_STORED_ON_DISK=FS_UNICODE_STORED_ON_DISK then
  917.           FileFlags:=FileFlags+[fsUnicodeStoredOnDisk];
  918.         if Flags and FS_PERSISTENT_ACLS=FS_PERSISTENT_ACLS then
  919.           FileFlags:=FileFlags+[fsPersistentAcls];
  920.         if Flags and FS_VOL_IS_COMPRESSED=FS_VOL_IS_COMPRESSED then
  921.           FileFlags:=FileFlags+[fsVolumeIsCompressed];
  922.         if Flags and FS_FILE_COMPRESSION=FS_FILE_COMPRESSION then
  923.           FileFlags:=FileFlags+[fsFileCompression];
  924.         if MCL=255 then
  925.           FileFlags:=FileFlags+[fsLongFileNames];
  926.         if Flags and FILE_SUPPORTS_ENCRYPTION=FILE_SUPPORTS_ENCRYPTION then
  927.           FileFlags:=FileFlags+[fsEncryptedFileSystemSupport];
  928.         if Flags and FILE_SUPPORTS_OBJECT_IDS=FILE_SUPPORTS_OBJECT_IDS then
  929.           FileFlags:=FileFlags+[fsObjectIDsSupport];
  930.         if Flags and FILE_SUPPORTS_REPARSE_POINTS=FILE_SUPPORTS_REPARSE_POINTS then
  931.           FileFlags:=FileFlags+[fsReparsePointsSupport];
  932.         if Flags and FILE_SUPPORTS_SPARSE_FILES=FILE_SUPPORTS_SPARSE_FILES then
  933.           FileFlags:=FileFlags+[fsSparseFilesSupport];
  934.         if Flags and FILE_VOLUME_QUOTAS=FILE_VOLUME_QUOTAS then
  935.           FileFlags:=FileFlags+[fsDiskQuotasSupport];
  936.       end;
  937.     end else begin
  938.       SectorsPerCluster:=0;
  939.       BytesPerSector:=0;
  940.       FreeClusters:=0;
  941.       TotalClusters:=0;
  942.       {$IFDEF D4PLUS}
  943.       Capacity:=0;
  944.       FreeSpace:=0;
  945.       {$ELSE}
  946.       Capacity.QuadPart:=0;
  947.       FreeSpace.QuadPart:=0;
  948.       {$ENDIF}
  949.       VolumeLabel:='';
  950.       SerialNumber:='';
  951.       FileSystem:='';
  952.       Serial:=0;
  953.     end;
  954.   end;
  955. end;
  956.  
  957. function GetMediaTypeStr(dt: TMediaType) :string;
  958. begin
  959.   case dt of
  960.     dtUnknown     :result:='Unknown';
  961.     dtNotExists   :result:='Not Exists';
  962.     dtRemovable   :result:='Removable';
  963.     dtFixed       :result:='Fixed';
  964.     dtRemote      :result:='Remote';
  965.     dtCDROM       :result:='CDROM';
  966.     dtRAMDisk     :result:='RAMDisk';
  967.   end;
  968. end;
  969.  
  970. function FileTimeToDateTimeStr(FileTime: TFileTime): string;
  971. var
  972.   LocFTime: TFileTime;
  973.   SysFTime: TSystemTime;
  974.   DateStr: string;
  975.   TimeStr: string;
  976.   FDateTimeStr: string;
  977.   Dt, Tm: TDateTime;
  978. begin
  979.   FileTimeToLocalFileTime(FileTime, LocFTime);
  980.   FileTimeToSystemTime(LocFTime, SysFTime);
  981.   try
  982.     with SysFTime do begin
  983.       Dt := EncodeDate(wYear, wMonth, wDay);
  984.       DateStr := DateToStr(Dt);
  985.       Tm := EncodeTime(wHour, wMinute, wSecond, wMilliseconds);
  986.       Timestr := TimeToStr(Tm);
  987.       FDateTimeStr := DateStr + '   ' + TimeStr;
  988.     end;
  989.     Result := DateTimeToStr(StrToDateTime(FDateTimeStr));
  990.   except
  991.     Result := '';
  992.   end;
  993. end;
  994.  
  995. function FiletimeToDateTime(FT: FILETIME): TDateTime;
  996. var
  997.   st: SYSTEMTIME;
  998.   dt1,dt2: TDateTime;
  999. begin
  1000.   FileTimeToSystemTime(FT,st);
  1001.   dt1:=EncodeTime(st.whour,st.wminute,st.wsecond,st.wMilliseconds);
  1002.   try
  1003.     dt2:=EncodeDate(st.wyear,st.wmonth,st.wday);
  1004.   except
  1005.     dt2:=0;
  1006.   end;
  1007.   Result:=dt1+dt2;
  1008. end;
  1009.  
  1010. function UTCToDateTime(UTC: DWORD): TDateTime;
  1011. var
  1012.   d: LARGE_INTEGER;
  1013.   ft: FILETIME;
  1014. begin
  1015.   d.QuadPart:=365*24*60*60;
  1016.   d.QuadPart:=((1970-1601)*d.QuadPart+UTC+89*24*60*60+3600)*10000000;
  1017.   ft.dwLowDateTime:=d.LowPart;
  1018.   ft.dwHighDateTime:=d.HighPart;
  1019.   Result:=FiletimeToDateTime(ft);
  1020. end;
  1021.  
  1022. function GetWinDir :string;
  1023. var
  1024.   n :dword;
  1025.   p :pchar;
  1026. begin
  1027.   n:=MAX_PATH;
  1028.   p:=stralloc(n);
  1029.   getwindowsdirectory(p,n);
  1030.   result:=strpas(p);
  1031.   strdispose(p);
  1032. end;
  1033.  
  1034. function GetSysDir :string;
  1035. var
  1036.   n :dword;
  1037.   p :pchar;
  1038. begin
  1039.   n:=MAX_PATH;
  1040.   p:=stralloc(n);
  1041.   getsystemdirectory(p,n);
  1042.   result:=strpas(p);
  1043.   strdispose(p);
  1044. end;
  1045.  
  1046. function GetTempDir :string;
  1047. var
  1048.   n :dword;
  1049.   p :pchar;
  1050. begin
  1051.   n:=MAX_PATH;
  1052.   p:=stralloc(n);
  1053.   gettemppath(n,p);
  1054.   result:=strpas(p);
  1055.   strdispose(p);
  1056. end;
  1057.  
  1058. function ExpandEnvVars;
  1059. var
  1060.   i,p: integer;
  1061.   sl: TStrings;
  1062.   s: string;
  1063. begin
  1064.   sl:=TStringList.Create;
  1065.   GetEnvironment(sl);
  1066.   for i:=0 to sl.Count-1 do begin
  1067.     s:='%'+sl.Names[i]+'%';
  1068.     p:=Pos(s,ASource);
  1069.     if p>0 then
  1070.       ASource:=Copy(ASource,1,p-1)+sl.Values[sl.names[i]]+Copy(ASource,p+Length(s),1024)
  1071.     else begin
  1072.       s:='\'+sl.Names[i];
  1073.       p:=Pos(s,ASource);
  1074.       if p>0 then
  1075.         ASource:=Copy(ASource,1,p-1)+sl.Values[sl.names[i]]+Copy(ASource,p+Length(s),1024);
  1076.     end;
  1077.   end;
  1078.   Result:=ASource;
  1079.   sl.Free;
  1080. end;
  1081.  
  1082. function GetProfilePath;
  1083. var
  1084.   s: string;
  1085. begin
  1086.   s:=GetSpecialFolder(GetDesktopWindow,CSIDL_DESKTOP);
  1087.   s:=ReverseStr(s);
  1088.   Result:=ReverseStr(Copy(s,Pos('\',s)+1,255));
  1089. end;
  1090.  
  1091. function GetAvailDisks :string;
  1092. var
  1093.   i,n :integer;
  1094.   buf :pchar;
  1095. begin
  1096.   buf:=stralloc(255);
  1097.   n:=GetLogicalDriveStrings(255,buf);
  1098.   result:='';
  1099.   for i:=0 to n do
  1100.     if buf[i]<>#0 then begin
  1101.       if (ord(buf[i]) in [$41..$5a]) or (ord(buf[i]) in [$61..$7a]) then
  1102.         result:=result+upcase(buf[i])
  1103.     end else
  1104.       if buf[i+1]=#0 then
  1105.         break;
  1106.   strdispose(buf);
  1107. end;
  1108.  
  1109. procedure GetCDs(cds :tstrings);
  1110. var
  1111.   i :integer;
  1112.   root :pchar;
  1113.   s :string;
  1114. begin
  1115.   root:=stralloc(255);
  1116.   s:=getavaildisks;
  1117.   cds.clear;
  1118.   for i:=1 to length(s) do begin
  1119.     strpcopy(root,copy(s,i,1)+':\');
  1120.     if getdrivetype(root)=drive_cdrom then
  1121.       cds.add(copy(root,1,length(root)-1));
  1122.   end;
  1123.   strdispose(root);
  1124. end;
  1125.  
  1126. function KillProcess;
  1127. var
  1128.   ph: THandle;
  1129. begin
  1130.   ph:=OpenProcess(PROCESS_TERMINATE,False,APID);
  1131.   Result:=ph<>0;
  1132.   if Result then
  1133.     TerminateProcess(ph,0);
  1134. end;
  1135.  
  1136. Function SubStr;
  1137. var
  1138.   p,l :integer;
  1139. begin
  1140.   p:=pos(uppercase(AFind),uppercase(ASource));
  1141.   if p>0 then begin
  1142.     l:=Length(AFind);
  1143.     Delete(ASource,p,l);
  1144.     Insert(AReplace,ASource,p);
  1145.   end;
  1146.   result:=ASource;
  1147. end;
  1148.  
  1149. function UniPath;
  1150. begin
  1151.   if (Path<>'') and (Copy(path,length(path),1)<>'\') then begin
  1152.     if not removebackslash then
  1153.       path:=path+'\'
  1154.   end else
  1155.     if removebackslash then
  1156.       delete(path,length(path),1);
  1157.   result:=path;
  1158. end;
  1159.  
  1160. procedure GetFileInfo;
  1161. var
  1162.   FI :TBYHANDLEFILEINFORMATION;
  1163.   shinfo :TSHFileInfo;
  1164.   h :THandle;
  1165.   ii :word;
  1166.   q :array [0..MAX_PATH - 1] of char;
  1167. begin
  1168.   h:=FileOpen(AFilename,fmOpenRead or fmShareDenyNone);
  1169.   if h<>0 then
  1170.     with AFileInfo do begin
  1171.       ii:=0;
  1172.       strpcopy(q,AFilename);
  1173.       if extracticon(hinstance,q,word(-1))>0 then
  1174.         iconhandle:=extracticon(hinstance,PChar(AFilename),ii)
  1175.       else
  1176.         iconhandle:=ExtractAssociatedIcon(hInstance,q,ii);
  1177.       if ShGetFileInfo(q,0,ShInfo,SizeOf(ShInfo),SHGFI_TYPENAME)<>0 then
  1178.         FileType:=ShInfo.szTypeName
  1179.       else
  1180.         FileType:='';
  1181.       GetFileInformationByHandle(h,FI);
  1182.       FileClose(h);
  1183.       Size:=FI.nFileSizelow+256*FI.nFileSizehigh;
  1184.       Attributes:=FI.dwFileAttributes;
  1185.       Created:=FileTimeToDateTime(FI.ftCreationTime);
  1186.       Accessed:=FileTimeToDateTime(FI.ftLastAccessTime);
  1187.       Modified:=FileTimeToDateTime(FI.ftLastWriteTime);
  1188.       BinaryType:=GetBinType(Afilename);
  1189.     end;
  1190. end;
  1191.  
  1192. function ExtractName;
  1193. var
  1194.   p :integer;
  1195. begin
  1196.   result:=extractfilename(AFilename);
  1197.   p:=pos('.',result);
  1198.   if p>0 then
  1199.     result:=copy(result,1,p-1);
  1200. end;
  1201.  
  1202. function HasAttr;
  1203. begin
  1204.   Result:=(FileGetAttr(AFileName) and AAttr)=AAttr;
  1205. end;
  1206.  
  1207. function DirExists;
  1208.   function StripTrailingBackslash(const Dir: string): string;
  1209.   begin
  1210.     Result := Dir;
  1211.     if (Result <> '') and (Result[Length(Result)] = '\') then
  1212.       SetLength(Result, Length(Result)-1);
  1213.   end;
  1214. var
  1215.   Tmp: string;
  1216.   DriveBits: set of 0..25;
  1217.   SR: TSearchRec;
  1218. begin
  1219.   if (Length(ADir) = 3) and (ADir[2] = ':') and (ADir[3] = '\') then begin
  1220.     Integer(DriveBits) := GetLogicalDrives;
  1221.     Tmp := UpperCase(ADir[1]);
  1222.     Result := (ord(Tmp[1]) - ord('A')) in DriveBits;
  1223.   end else begin
  1224.     Result := (FindFirst(StripTrailingBackslash(ADir), faDirectory, SR) = 0) and (ADir <> '');
  1225.     if Result then
  1226.       Result := (SR.Attr and faDirectory) = faDirectory;
  1227.     sysutils.FindClose(SR);
  1228.   end;
  1229. end;
  1230.  
  1231. function GetBinType;
  1232. var
  1233.   BinaryType: DWORD;
  1234.   fi :TSHFileInfo;
  1235. const
  1236.   IMAGE_DOS_SIGNATURE    = $5A4D; // MZ
  1237.   IMAGE_OS2_SIGNATURE    = $454E; // NE
  1238.   IMAGE_VXD_SIGNATURE    = $454C; // LE
  1239.   IMAGE_NT_SIGNATURE     = $0000; // PE
  1240.   IMAGE_32_SIGNATURE     = $4550;
  1241. begin
  1242.   binarytype:=SHGetFileInfo(PChar(AFilename),0,fi,sizeof(fi),SHGFI_EXETYPE);
  1243.   result:='';
  1244.   if binarytype<>0 then
  1245.     case loword(binarytype) of
  1246.       IMAGE_DOS_SIGNATURE: result:='DOS Executable';
  1247.       IMAGE_VXD_SIGNATURE: result:='Virtual Device Driver';
  1248.       IMAGE_OS2_SIGNATURE,IMAGE_NT_SIGNATURE, IMAGE_32_SIGNATURE:
  1249.       case hiword(binarytype) of
  1250.         $400: result:='Win32 Executable';
  1251.         $30A,$300: result:='Win16 Executable';
  1252.         $0 :result:='Win32 Console Executable';
  1253.       end;
  1254.     end;
  1255.   if Result='' then
  1256.     if GetBinaryType(Pchar(AFilename),Binarytype) then
  1257.       case BinaryType of
  1258.         SCS_32BIT_BINARY: result:= 'Win32 Executable';
  1259.         SCS_DOS_BINARY  : result:= 'DOS Executable';
  1260.         SCS_WOW_BINARY  : result:= 'Win16 Executable';
  1261.         SCS_PIF_BINARY  : result:= 'PIF File';
  1262.         SCS_POSIX_BINARY: result:= 'POSIX Executable';
  1263.         SCS_OS216_BINARY: result:= 'OS/2 16 bit Executable'
  1264.       end;
  1265. end;
  1266.  
  1267. function ExtractUNCFilename;
  1268. var
  1269.   p,l :integer;
  1270. begin
  1271.   p:=pos(':',ASource);
  1272.   if p>0 then begin
  1273.     l:=Length(ASource);
  1274.     result:=Copy(ASource,p-1,l-p+2);
  1275.   end else
  1276.     result:=ASource;
  1277. end;
  1278.  
  1279. function FileCopy;
  1280. var
  1281.   CopyBuffer: Pointer;
  1282.   BytesCopied: Longint;
  1283.   Source, Dest: Integer;
  1284.   Destination: TFileName;
  1285. const
  1286.   ChunkSize: Longint = 8192;
  1287. begin
  1288.   Result:=False;
  1289.   Destination := ExpandFileName(ADestName);
  1290. {  if HasAttr(Destination, faDirectory) then
  1291.     Destination := UniPath(Destination,true) + ExtractFileName(AFileName);}
  1292.   GetMem(CopyBuffer, ChunkSize);
  1293.   try
  1294.     Source:=FileOpen(AFileName, fmShareDenyNone);
  1295.     if not(Source<0) then
  1296.       try
  1297.         Dest:=FileCreate(Destination);
  1298.         if not(Dest<0) then
  1299.           try
  1300.             repeat
  1301.               BytesCopied:=FileRead(Source, CopyBuffer^, ChunkSize);
  1302.               if BytesCopied>0 then
  1303.                  FileWrite(Dest, CopyBuffer^, BytesCopied);
  1304.              until BytesCopied<ChunkSize;
  1305.              Result:=True;
  1306.           finally
  1307.             FileClose(Dest);
  1308.           end;
  1309.         finally
  1310.           FileClose(Source);
  1311.         end;
  1312.   finally
  1313.     FreeMem(CopyBuffer, ChunkSize);
  1314.   end;
  1315. end;
  1316.  
  1317. function FileMove;
  1318. var
  1319.   Destination: string;
  1320. begin
  1321.   Result:=True;
  1322.   Destination := ExpandFileName(ADestName);
  1323.   if not RenameFile(AFileName, Destination) then begin
  1324.     if HasAttr(AFileName, faReadOnly) then begin
  1325.       Result:=False;
  1326.       Exit;
  1327.     end;
  1328.     FileCopy(AFileName, Destination);
  1329.     DeleteFile(AFilename);
  1330.   end;
  1331. end;
  1332.  
  1333. function IsBitOn (Value: Integer; Bit: Byte): Boolean;
  1334. begin
  1335.   Result:=(Value and (1 shl Bit))<>0;
  1336. end;
  1337.  
  1338.  
  1339. function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile,
  1340.    ErrMsg :string): boolean;
  1341. const
  1342.   ROUTINE_ID = '[function: CreateDOSProcessRedirected]';
  1343. var
  1344.   pCommandLine: array[0..MAX_PATH] of char;
  1345.   pInputFile,
  1346.   pOutPutFile: array[0..MAX_PATH] of char;
  1347.   StartupInfo: TStartupInfo;
  1348.   ProcessInfo: TProcessInformation;
  1349.   SecAtrrs: TSecurityAttributes;
  1350.   hAppProcess,
  1351.   hAppThread,
  1352.   hInputFile,
  1353.   hOutputFile   : THandle;
  1354. begin
  1355.   Result := FALSE;
  1356.   if (InputFile<>'') and (not FileExists(InputFile)) then
  1357.     raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
  1358.        'Input file * %s *' + #10 +
  1359.        'does not exist' + #10 + #10 +
  1360.        ErrMsg, [InputFile]);
  1361.   hAppProcess:=0;
  1362.   hAppThread:=0;
  1363.   hInputFile:=0;
  1364.   hOutputFile:=0;
  1365.   try
  1366.     StrPCopy(pCommandLine, CommandLine);
  1367.     StrPCopy(pInputFile, InputFile);
  1368.     StrPCopy(pOutPutFile, OutputFile);
  1369.     { prepare SecAtrrs structure for the CreateFile calls.  This SecAttrs
  1370.       structure is needed in this case because we want the returned handle to
  1371.       be inherited by child process. This is true when running under WinNT.
  1372.       As for Win95, the parameter is ignored. }
  1373.     FillChar(SecAtrrs,SizeOf(SecAtrrs),#0);
  1374.     SecAtrrs.nLength:=SizeOf(SecAtrrs);
  1375.     SecAtrrs.lpSecurityDescriptor:=nil;
  1376.     SecAtrrs.bInheritHandle:=TRUE;
  1377.     if InputFile<>'' then begin
  1378.       hInputFile:=CreateFile(
  1379.          pInputFile,                          { pointer to name of the file }
  1380.          GENERIC_READ or GENERIC_WRITE,       { access (read-write) mode }
  1381.          FILE_SHARE_READ or FILE_SHARE_WRITE, { share mode }
  1382.          @SecAtrrs,                           { pointer to security attributes }
  1383.          OPEN_ALWAYS,                         { how to create }
  1384.          FILE_ATTRIBUTE_NORMAL
  1385.          or FILE_FLAG_WRITE_THROUGH,          { file attributes }
  1386.          0);                                 { handle to file with attrs to copy }
  1387.       if hInputFile = INVALID_HANDLE_VALUE then
  1388.         raise Exception.CreateFmt(ROUTINE_ID + #10 +  #10 +
  1389.            'WinApi function CreateFile returned an invalid handle value' + #10 +
  1390.            'for the input file * %s *' + #10 + #10 +
  1391.             ErrMsg, [InputFile]);
  1392.     end else
  1393.       hInputFile:=0;
  1394.  
  1395.     hOutputFile:=CreateFile(
  1396.        pOutPutFile,                         { pointer to name of the file }
  1397.        GENERIC_READ or GENERIC_WRITE,       { access (read-write) mode }
  1398.        FILE_SHARE_READ or FILE_SHARE_WRITE, { share mode }
  1399.        @SecAtrrs,                           { pointer to security attributes }
  1400.        CREATE_ALWAYS,                       { how to create }
  1401.        FILE_ATTRIBUTE_NORMAL
  1402.        or FILE_FLAG_WRITE_THROUGH,          { file attributes }
  1403.        0 );                                 { handle to file with attrs to copy }
  1404.     if hOutputFile=INVALID_HANDLE_VALUE then
  1405.       raise Exception.CreateFmt(ROUTINE_ID + #10 +  #10 +
  1406.          'WinApi function CreateFile returned an invalid handle value'  + #10 +
  1407.          'for the output file * %s *' + #10 + #10 +
  1408.          ErrMsg, [OutputFile]);
  1409.  
  1410.     FillChar(StartupInfo, SizeOf(StartupInfo), #0);
  1411.     StartupInfo.cb:=SizeOf(StartupInfo);
  1412.     StartupInfo.dwFlags:=STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
  1413.     StartupInfo.wShowWindow:=SW_HIDE;
  1414.     StartupInfo.hStdOutput:=hOutputFile;
  1415.     StartupInfo.hStdInput:=hInputFile;
  1416.  
  1417.     Result:=CreateProcess(
  1418.        NIL,                           { pointer to name of executable module }
  1419.        pCommandLine,                  { pointer to command line string }
  1420.        NIL,                           { pointer to process security attributes }
  1421.        NIL,                           { pointer to thread security attributes }
  1422.        TRUE,                          { handle inheritance flag }
  1423.        HIGH_PRIORITY_CLASS,           { creation flags }
  1424.        NIL,                           { pointer to new environment block }
  1425.        NIL,                           { pointer to current directory name }
  1426.        StartupInfo,                   { pointer to STARTUPINFO }
  1427.        ProcessInfo);                  { pointer to PROCESS_INF }
  1428.  
  1429.     if Result then begin
  1430.       WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
  1431.       hAppProcess:=ProcessInfo.hProcess;
  1432.       hAppThread:=ProcessInfo.hThread;
  1433.     end else
  1434.       raise Exception.Create(ROUTINE_ID + #10 +  #10 +
  1435.          'Function failure'  + #10 +  #10 + ErrMsg);
  1436.   finally
  1437.     if hOutputFile <> 0 then
  1438.       CloseHandle(hOutputFile);
  1439.     if hInputFile <> 0 then
  1440.       CloseHandle(hInputFile);
  1441.     if hAppThread <> 0 then
  1442.       CloseHandle(hAppThread);
  1443.     if hAppProcess <> 0 then
  1444.       CloseHandle(hAppProcess);
  1445.   end;
  1446. end;
  1447.  
  1448. function OpenMailSlot(Const Server, Slot : String): THandle;
  1449. var
  1450.   FullSlot : String;
  1451. begin
  1452.   FullSlot := '\\'+Server+'\mailslot\'+Slot;
  1453.   Result := CreateFile(
  1454.     PChar(FullSlot),
  1455.     GENERIC_WRITE,
  1456.     FILE_SHARE_READ,
  1457.     NIL,
  1458.     OPEN_EXISTING,
  1459.     FILE_ATTRIBUTE_NORMAL,
  1460.     0                    );
  1461. end;
  1462.  
  1463. function SendToMailSlot(Const Server, Slot, Mail : String) : Boolean;
  1464. var
  1465.   hToSlot : THandle;
  1466.   BytesWritten : DWord;
  1467. begin
  1468.   Result := False;
  1469.   hToSlot := OpenMailSlot(Server,Slot);
  1470.   If hToSlot = INVALID_HANDLE_VALUE Then
  1471.     Exit;
  1472.   try
  1473.     BytesWritten := 0;
  1474.     if (NOT WriteFile(hToSlot,
  1475.                       Pointer(Mail)^,
  1476.                       Length(Mail),
  1477.                       BytesWritten,
  1478.                       NIL))         OR
  1479.         (BytesWritten <> Length(Mail)) Then
  1480.       Exit;
  1481.     Result := True;
  1482.   finally
  1483.     CloseHandle(hToSlot);
  1484.   end;
  1485. end;
  1486.  
  1487. function SendToWinpopup(Server, Reciever, Sender, Msg : String) : Boolean;
  1488. var
  1489.   szserver,szsender,szreciever,szmsg :pchar;
  1490. begin
  1491.   szserver:=stralloc(255);
  1492.   szsender:=stralloc(255);
  1493.   szreciever:=stralloc(255);
  1494.   szmsg:=stralloc(255);
  1495.   CharToOEM(PChar(Server),szServer);
  1496.   CharToOEM(PChar(Sender),szSender);
  1497.   CharToOEM(PChar(Reciever),szReciever);
  1498.   CharToOEM(PChar(Msg),szMsg);
  1499.   Result := SendToMailSlot(Server, wpslot, szSender+#0+szReciever+#0+szMsg);
  1500.   strdispose(szserver);
  1501.   strdispose(szsender);
  1502.   strdispose(szreciever);
  1503.   strdispose(szmsg);
  1504. end;
  1505.  
  1506. function EncodeBase (I: Int64; Base: Byte): String;
  1507. var
  1508.   D,J: Int64;
  1509.   N: Byte;
  1510. const ConversionAlphabeth : String [36] = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  1511. begin
  1512.   if I = 0 then begin
  1513.      Result := '0';
  1514.      exit;
  1515.   end;
  1516.   D := Round (Power (Base, Trunc (Log10 (I) / Log10 (Base)) + 1));            // +1 to fix occasional real "fuzz"
  1517.   J := I;
  1518.   Result := '';
  1519.   While D > 0 do begin
  1520.     N := J div D;
  1521.     if (N <> 0) or (Result <> '') then                                      // "fuzz" bug
  1522.       Result := Result + ConversionAlphabeth [N + 1];
  1523.     J := J mod D;
  1524.     D := D div Base;
  1525.   end;
  1526. end;
  1527.  
  1528. function GetFontRes: DWORD;
  1529. var
  1530.   tm: TTextMetric;
  1531.   hwnd,hdc: THandle;
  1532.   MapMode: DWORD;
  1533. begin
  1534.   hwnd:=GetDesktopWindow;
  1535.   hdc:=GetWindowDC(hwnd);
  1536.   if hdc>0 then begin
  1537.     MapMode:=SetMapMode(hdc,MM_TEXT);
  1538.     GetTextMetrics(hdc,tm);
  1539.     MapMode:=SetMapMode(hdc,MapMode);
  1540.     ReleaseDC(hwnd,hdc);
  1541.     Result:=tm.tmHeight;
  1542.   end;
  1543. end;
  1544.  
  1545. function TrimAll;
  1546. var
  1547.   p :integer;
  1548. begin
  1549.   ASource:=trim(ASource);
  1550.   p:=pos(' ',ASource);
  1551.   while p>0 do begin
  1552.     Delete(ASource,p,1);
  1553.     p:=pos(' ',ASource);
  1554.   end;
  1555.   p:=Pos(#13#10,ASource);
  1556.   while p>0 do begin
  1557.     Delete(ASource,p,2);
  1558.     p:=Pos(#13#10,ASource);
  1559.   end;
  1560.   result:=ASource;
  1561. end;
  1562.  
  1563. function booltostr;
  1564. begin
  1565.   if AValue then begin
  1566.     if AVerbose then
  1567.       result:='True'
  1568.     else
  1569.       result:='1';
  1570.   end else begin
  1571.     if AVerbose then
  1572.       result:='False'
  1573.     else
  1574.       result:='0';
  1575.   end;
  1576. end;
  1577.  
  1578. function StrtoBool;
  1579. begin
  1580.   Result:=false;
  1581.   ASource:=UpperCase(ASource);
  1582.   if (ASource='TRUE') or (ASource='1') then
  1583.     Result:=true;
  1584. end;
  1585.  
  1586. procedure AddWord;
  1587. begin
  1588.   if Length(ADest)>0 then
  1589.     ADest:=ADest+ADelimiter+AWord
  1590.   else
  1591.     ADest:=ADest+AWord;
  1592. end;
  1593.  
  1594. function GetDelimitedText;
  1595. var
  1596.   i :integer;
  1597. begin
  1598.   result:='';
  1599.   for i:=0 to AList.Count-1 do
  1600.     Result:=Result+AList[i]+ADelimiter;
  1601.     if Result<>'' then
  1602.       Delete(Result,Length(Result)-Length(ADelimiter)+1,Length(ADelimiter));
  1603. end;
  1604.  
  1605. procedure SetDelimitedText;
  1606. var
  1607.   p: integer;
  1608. begin
  1609.   AList.Clear;
  1610.   p:=Pos(ADelimiter,ASource);
  1611.   while p>0 do begin
  1612.     AList.Add(Copy(ASource,1,p-1));
  1613.     Delete(ASource,1,p+Length(Adelimiter)-1);
  1614.     p:=Pos(ADelimiter,ASource);
  1615.   end;
  1616.   AList.Add(ASource);
  1617. end;
  1618.  
  1619. function FitStr;
  1620. var
  1621.   lf :integer;
  1622.   s :string;
  1623. begin
  1624.   lf:=Length(ASource);
  1625.   if lf>ALength then begin
  1626.     result:=Copy(ASource,1,3);
  1627.     s:=Copy(ASource,lf-ALength+7,lf);
  1628.     result:=Result+AEllipsis+s;
  1629.   end else
  1630.     result:=ASource;
  1631. end;
  1632.  
  1633. function GetToken;
  1634. var
  1635.   i,p :integer;
  1636. begin
  1637.   p:=pos(adelimiter,s);
  1638.   i:=1;
  1639.   while (p>0) and (i<index) do begin
  1640.     inc(i);
  1641.     delete(s,1,p);
  1642.     p:=pos(adelimiter,s);
  1643.   end;
  1644.   result:=copy(s,1,p-1);
  1645. end;
  1646.  
  1647. procedure SetToken;
  1648. var
  1649.   i,p,sx,ex :integer;
  1650.   s1 :string;
  1651. begin
  1652.   s1:=s;
  1653.   p:=pos(adelimiter,s1);
  1654.   sx:=0;
  1655.   i:=0;
  1656.   while (p>0) and (i<index) do begin
  1657.     inc(sx,p);
  1658.     inc(i);
  1659.     delete(s1,1,p);
  1660.     p:=pos(adelimiter,s1);
  1661.   end;
  1662.   ex:=sx+p;
  1663.   s:=copy(s,1,sx)+newvalue+copy(s,ex,255);
  1664. end;
  1665.  
  1666. function ExtractWord;
  1667. Var
  1668.   I,J:Word;
  1669.   Count:Byte;
  1670.   SLen:Integer;
  1671. Begin
  1672.   Count := 0;
  1673.   I := 1;
  1674.   Result := '';
  1675.   SLen := Length(S);
  1676.   While I <= SLen Do Begin
  1677.     While (I <= SLen) And (S[I] In WordDelims) Do Inc(I);
  1678.     If I <= SLen Then Inc(Count);
  1679.     J := I;
  1680.     While (J <= SLen) And Not(S[J] In WordDelims) Do Inc(J);
  1681.     If Count = N Then Begin
  1682.       Result := Copy(S,I,J-I);
  1683.       Exit
  1684.     End;
  1685.     I := J;
  1686.   End;
  1687. end;
  1688.  
  1689. function TestByMask(const S, Mask: string; MaskChar: Char): Boolean;
  1690. asm
  1691.         TEST    EAX,EAX
  1692.         JE      @@qt2
  1693.         PUSH    EBX
  1694.         TEST    EDX,EDX
  1695.         JE      @@qt1
  1696.         MOV     EBX,[EAX-4]
  1697.         CMP     EBX,[EDX-4]
  1698.         JE      @@01
  1699. @@qt1:  XOR     EAX,EAX
  1700.         POP     EBX
  1701. @@qt2:  RET
  1702. @@01:   DEC     EBX
  1703.         JS      @@07
  1704. @@lp:   MOV     CH,BYTE PTR [EDX+EBX]
  1705.         CMP     CL,CH
  1706.         JNE     @@cm
  1707.         DEC     EBX
  1708.         JS      @@eq
  1709.         MOV     CH,BYTE PTR [EDX+EBX]
  1710.         CMP     CL,CH
  1711.         JNE     @@cm
  1712.         DEC     EBX
  1713.         JS      @@eq
  1714.         MOV     CH,BYTE PTR [EDX+EBX]
  1715.         CMP     CL,CH
  1716.         JNE     @@cm
  1717.         DEC     EBX
  1718.         JS      @@eq
  1719.         MOV     CH,BYTE PTR [EDX+EBX]
  1720.         CMP     CL,CH
  1721.         JNE     @@cm
  1722.         DEC     EBX
  1723.         JNS     @@lp
  1724.         JMP     @@eq
  1725. @@cm:   CMP     CH,BYTE PTR [EAX+EBX]
  1726.         JNE     @@07
  1727.         DEC     EBX
  1728.         JNS     @@lp
  1729. @@eq:   MOV     EAX,1
  1730.         POP     EBX
  1731.         RET
  1732. @@07:   XOR     EAX,EAX
  1733.         POP     EBX
  1734. end;
  1735.  
  1736. function IsLeapYear(Year: Word): Boolean;
  1737. begin
  1738.   Result:=((Year and 3)=0) and ((Year mod 100>0) or (Year mod 400=0));
  1739. end;
  1740.  
  1741. function DaysInMonth(const DT: TDateTime): Byte;
  1742. var
  1743.   y,m,d: Word;
  1744. begin
  1745.   DecodeDate(DT,y,m,d);
  1746.   case m of
  1747.     2: if IsLeapYear(y) then
  1748.          Result:=29
  1749.        else
  1750.          Result:=28;
  1751.     4, 6, 9, 11: Result:=30;
  1752.     else
  1753.       Result := 31;
  1754.   end;
  1755. end;
  1756.  
  1757. function DayOfMonth2Date(year,month,weekInMonth,dayInWeek: word): TDateTime;
  1758. var
  1759.   days: integer;
  1760.   day : integer;
  1761. begin
  1762.   if (weekInMonth>=1) and (weekInMonth<=4) then begin
  1763.     day:=DayOfWeek(EncodeDate(year,month,1));
  1764.     day:=1+dayInWeek-day;
  1765.     if day<=0 then
  1766.       Inc(day,7);
  1767.     day:=day+7*(weekInMonth-1);
  1768.     Result:=EncodeDate(year,month,day);
  1769.   end else
  1770.     if weekInMonth=5 then begin
  1771.       days:=DaysInMonth(EncodeDate(year,month,1));
  1772.       day:=DayOfWeek(EncodeDate(year,month,days));
  1773.       day:=days+(dayInWeek-day);
  1774.       if day>days then
  1775.         Dec(day,7);
  1776.       Result:=EncodeDate(year,month,day);
  1777.     end else
  1778.       Result:=0;
  1779. end;
  1780.  
  1781. function DSTDate2Date(dstDate: TSystemTime; year: word): TDateTime;
  1782. begin
  1783.   if dstDate.wMonth=0 then
  1784.     Result:=0
  1785.   else
  1786.     if dstDate.wYear=0 then
  1787.       Result:=DayOfMonth2Date(year,dstDate.wMonth,dstDate.wDay,dstDate.wDayOfWeek+1)+
  1788.               EncodeTime(dstDate.wHour,dstDate.wMinute,dstDate.wSecond,dstDate.wMilliseconds)
  1789.     else
  1790.       Result:=SystemTimeToDateTime(dstDate);
  1791. end;
  1792.  
  1793. function GetOpenFileDlg;
  1794. begin
  1795.   if ADir='' then
  1796.     ADir:=ExtractFilePath(ParamStr(0));
  1797.   StrPCopy(PChar(@buffer),FileName);
  1798.   ofn.lStructSize:=SizeOf(TOpenFilename);
  1799.   ofn.hWndOwner:=AHandle;
  1800.   ofn.hInstance:=HInstance;
  1801.   ofn.lpstrFilter:=PChar(AFilter);
  1802.   ofn.lpstrFile:=buffer;
  1803.   ofn.nMaxFile:=MAXSIZE;
  1804.   ofn.lpstrTitle:=PChar(ATitle);
  1805.   ofn.lpstrInitialDir:=PChar(ADir);
  1806.   if AOpenDlg then begin
  1807.     ofn.Flags:=OFN_FILEMUSTEXIST or OFN_PATHMUSTEXIST or
  1808.                OFN_LONGNAMES or OFN_EXPLORER or OFN_HIDEREADONLY;
  1809.     Result:=GetOpenFileName(ofn);
  1810.   end else begin
  1811.     ofn.Flags:=OFN_PATHMUSTEXIST or OFN_OVERWRITEPROMPT or
  1812.                OFN_LONGNAMES or OFN_EXPLORER or OFN_HIDEREADONLY;
  1813.     Result:=GetSaveFileName(ofn);
  1814.   end;
  1815.   Filename:=buffer;
  1816. end;
  1817.  
  1818. initialization
  1819.   Os:=GetOS;
  1820.   IsNT:=OS in [osNT3,osNT4,os2K];
  1821.   IS95:=OS=os95;
  1822.   Is98:=OS=os98;
  1823.   Is2K:=OS=os2K;
  1824.   IsOSR2:=OS=os95OSR2;
  1825.   IsSE:=OS=os98SE;
  1826.   IsME:=OS=osME;
  1827.   IsXP:=OS=osXP;
  1828.   WindowsUser:=GetUser;
  1829.   MachineName:=GetMachine;
  1830.   ProfilePath:=GetProfilePath;
  1831.   case OS of
  1832.     os95, os95OSR2: OSVersion:='Windows 95';
  1833.     os98, os98SE: OSVersion:='Windows 98';
  1834.     osME: OSVersion:='Windows Millenium Edition';
  1835.     osNT3, osNT4: OSVersion:='Windows NT';
  1836.     os2K: OSVersion:='Windows 2000';
  1837.     osXP: OSVersion:='Windows XP';
  1838.   end;
  1839.   if IsNT then
  1840.     ClassKey:='SYSTEM\CurrentControlSet\Control\Class'
  1841.   else
  1842.     ClassKey:='SYSTEM\CurrentControlSet\Services\Class';
  1843. end.
  1844.