home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / kompon / d56 / MSYSINFO.ZIP / Source / MiTeC_Routines.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-07-24  |  53.4 KB  |  1,849 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {             MiTeC Common Routines                     }
  5. {           version 1.4 for Delphi 3,4,5,6              }
  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.   try
  1002.     dt1:=EncodeTime(st.whour,st.wminute,st.wsecond,st.wMilliseconds);
  1003.   except
  1004.     dt1:=0;
  1005.   end;
  1006.   try
  1007.     dt2:=EncodeDate(st.wyear,st.wmonth,st.wday);
  1008.   except
  1009.     dt2:=0;
  1010.   end;
  1011.   Result:=dt1+dt2;
  1012. end;
  1013.  
  1014. function UTCToDateTime(UTC: DWORD): TDateTime;
  1015. var
  1016.   d: LARGE_INTEGER;
  1017.   ft: FILETIME;
  1018. begin
  1019.   d.QuadPart:=365*24*60*60;
  1020.   d.QuadPart:=((1970-1601)*d.QuadPart+UTC+89*24*60*60+3600)*10000000;
  1021.   ft.dwLowDateTime:=d.LowPart;
  1022.   ft.dwHighDateTime:=d.HighPart;
  1023.   Result:=FiletimeToDateTime(ft);
  1024. end;
  1025.  
  1026. function GetWinDir :string;
  1027. var
  1028.   n :dword;
  1029.   p :pchar;
  1030. begin
  1031.   n:=MAX_PATH;
  1032.   p:=stralloc(n);
  1033.   getwindowsdirectory(p,n);
  1034.   result:=strpas(p);
  1035.   strdispose(p);
  1036. end;
  1037.  
  1038. function GetSysDir :string;
  1039. var
  1040.   n :dword;
  1041.   p :pchar;
  1042. begin
  1043.   n:=MAX_PATH;
  1044.   p:=stralloc(n);
  1045.   getsystemdirectory(p,n);
  1046.   result:=strpas(p);
  1047.   strdispose(p);
  1048. end;
  1049.  
  1050. function GetTempDir :string;
  1051. var
  1052.   n :dword;
  1053.   p :pchar;
  1054. begin
  1055.   n:=MAX_PATH;
  1056.   p:=stralloc(n);
  1057.   gettemppath(n,p);
  1058.   result:=strpas(p);
  1059.   strdispose(p);
  1060. end;
  1061.  
  1062. function ExpandEnvVars;
  1063. var
  1064.   i,p: integer;
  1065.   sl: TStrings;
  1066.   s: string;
  1067. begin
  1068.   sl:=TStringList.Create;
  1069.   GetEnvironment(sl);
  1070.   for i:=0 to sl.Count-1 do begin
  1071.     s:='%'+sl.Names[i]+'%';
  1072.     p:=Pos(s,ASource);
  1073.     if p>0 then
  1074.       ASource:=Copy(ASource,1,p-1)+sl.Values[sl.names[i]]+Copy(ASource,p+Length(s),1024)
  1075.     else begin
  1076.       s:='\'+sl.Names[i];
  1077.       p:=Pos(s,ASource);
  1078.       if p>0 then
  1079.         ASource:=Copy(ASource,1,p-1)+sl.Values[sl.names[i]]+Copy(ASource,p+Length(s),1024);
  1080.     end;
  1081.   end;
  1082.   Result:=ASource;
  1083.   sl.Free;
  1084. end;
  1085.  
  1086. function GetProfilePath;
  1087. var
  1088.   s: string;
  1089. begin
  1090.   s:=GetSpecialFolder(GetDesktopWindow,CSIDL_DESKTOP);
  1091.   s:=ReverseStr(s);
  1092.   Result:=ReverseStr(Copy(s,Pos('\',s)+1,255));
  1093. end;
  1094.  
  1095. function GetAvailDisks :string;
  1096. var
  1097.   i,n :integer;
  1098.   buf :pchar;
  1099. begin
  1100.   buf:=stralloc(255);
  1101.   n:=GetLogicalDriveStrings(255,buf);
  1102.   result:='';
  1103.   for i:=0 to n do
  1104.     if buf[i]<>#0 then begin
  1105.       if (ord(buf[i]) in [$41..$5a]) or (ord(buf[i]) in [$61..$7a]) then
  1106.         result:=result+upcase(buf[i])
  1107.     end else
  1108.       if buf[i+1]=#0 then
  1109.         break;
  1110.   strdispose(buf);
  1111. end;
  1112.  
  1113. procedure GetCDs(cds :tstrings);
  1114. var
  1115.   i :integer;
  1116.   root :pchar;
  1117.   s :string;
  1118. begin
  1119.   root:=stralloc(255);
  1120.   s:=getavaildisks;
  1121.   cds.clear;
  1122.   for i:=1 to length(s) do begin
  1123.     strpcopy(root,copy(s,i,1)+':\');
  1124.     if getdrivetype(root)=drive_cdrom then
  1125.       cds.add(copy(root,1,length(root)-1));
  1126.   end;
  1127.   strdispose(root);
  1128. end;
  1129.  
  1130. function KillProcess;
  1131. var
  1132.   ph: THandle;
  1133. begin
  1134.   ph:=OpenProcess(PROCESS_TERMINATE,False,APID);
  1135.   Result:=ph<>0;
  1136.   if Result then
  1137.     TerminateProcess(ph,0);
  1138. end;
  1139.  
  1140. Function SubStr;
  1141. var
  1142.   p,l :integer;
  1143. begin
  1144.   p:=pos(uppercase(AFind),uppercase(ASource));
  1145.   if p>0 then begin
  1146.     l:=Length(AFind);
  1147.     Delete(ASource,p,l);
  1148.     Insert(AReplace,ASource,p);
  1149.   end;
  1150.   result:=ASource;
  1151. end;
  1152.  
  1153. function UniPath;
  1154. begin
  1155.   if (Path<>'') and (Copy(path,length(path),1)<>'\') then begin
  1156.     if not removebackslash then
  1157.       path:=path+'\'
  1158.   end else
  1159.     if removebackslash then
  1160.       delete(path,length(path),1);
  1161.   result:=path;
  1162. end;
  1163.  
  1164. procedure GetFileInfo;
  1165. var
  1166.   FI :TBYHANDLEFILEINFORMATION;
  1167.   shinfo :TSHFileInfo;
  1168.   h :THandle;
  1169.   ii :word;
  1170.   q :array [0..MAX_PATH - 1] of char;
  1171. begin
  1172.   h:=FileOpen(AFilename,fmOpenRead or fmShareDenyNone);
  1173.   if h<>0 then
  1174.     with AFileInfo do begin
  1175.       ii:=0;
  1176.       strpcopy(q,AFilename);
  1177.       if extracticon(hinstance,q,word(-1))>0 then
  1178.         iconhandle:=extracticon(hinstance,PChar(AFilename),ii)
  1179.       else
  1180.         iconhandle:=ExtractAssociatedIcon(hInstance,q,ii);
  1181.       if ShGetFileInfo(q,0,ShInfo,SizeOf(ShInfo),SHGFI_TYPENAME)<>0 then
  1182.         FileType:=ShInfo.szTypeName
  1183.       else
  1184.         FileType:='';
  1185.       GetFileInformationByHandle(h,FI);
  1186.       FileClose(h);
  1187.       Size:=FI.nFileSizelow+256*FI.nFileSizehigh;
  1188.       Attributes:=FI.dwFileAttributes;
  1189.       Created:=FileTimeToDateTime(FI.ftCreationTime);
  1190.       Accessed:=FileTimeToDateTime(FI.ftLastAccessTime);
  1191.       Modified:=FileTimeToDateTime(FI.ftLastWriteTime);
  1192.       BinaryType:=GetBinType(Afilename);
  1193.     end;
  1194. end;
  1195.  
  1196. function ExtractName;
  1197. var
  1198.   p :integer;
  1199. begin
  1200.   result:=extractfilename(AFilename);
  1201.   p:=pos('.',result);
  1202.   if p>0 then
  1203.     result:=copy(result,1,p-1);
  1204. end;
  1205.  
  1206. function HasAttr;
  1207. begin
  1208.   Result:=(FileGetAttr(AFileName) and AAttr)=AAttr;
  1209. end;
  1210.  
  1211. function DirExists;
  1212.   function StripTrailingBackslash(const Dir: string): string;
  1213.   begin
  1214.     Result := Dir;
  1215.     if (Result <> '') and (Result[Length(Result)] = '\') then
  1216.       SetLength(Result, Length(Result)-1);
  1217.   end;
  1218. var
  1219.   Tmp: string;
  1220.   DriveBits: set of 0..25;
  1221.   SR: TSearchRec;
  1222. begin
  1223.   if (Length(ADir) = 3) and (ADir[2] = ':') and (ADir[3] = '\') then begin
  1224.     Integer(DriveBits) := GetLogicalDrives;
  1225.     Tmp := UpperCase(ADir[1]);
  1226.     Result := (ord(Tmp[1]) - ord('A')) in DriveBits;
  1227.   end else begin
  1228.     Result := (FindFirst(StripTrailingBackslash(ADir), faDirectory, SR) = 0) and (ADir <> '');
  1229.     if Result then
  1230.       Result := (SR.Attr and faDirectory) = faDirectory;
  1231.     sysutils.FindClose(SR);
  1232.   end;
  1233. end;
  1234.  
  1235. function GetBinType;
  1236. var
  1237.   BinaryType: DWORD;
  1238.   fi :TSHFileInfo;
  1239. const
  1240.   IMAGE_DOS_SIGNATURE    = $5A4D; // MZ
  1241.   IMAGE_OS2_SIGNATURE    = $454E; // NE
  1242.   IMAGE_VXD_SIGNATURE    = $454C; // LE
  1243.   IMAGE_NT_SIGNATURE     = $0000; // PE
  1244.   IMAGE_32_SIGNATURE     = $4550;
  1245. begin
  1246.   binarytype:=SHGetFileInfo(PChar(AFilename),0,fi,sizeof(fi),SHGFI_EXETYPE);
  1247.   result:='';
  1248.   if binarytype<>0 then
  1249.     case loword(binarytype) of
  1250.       IMAGE_DOS_SIGNATURE: result:='DOS Executable';
  1251.       IMAGE_VXD_SIGNATURE: result:='Virtual Device Driver';
  1252.       IMAGE_OS2_SIGNATURE,IMAGE_NT_SIGNATURE, IMAGE_32_SIGNATURE:
  1253.       case hiword(binarytype) of
  1254.         $400: result:='Win32 Executable';
  1255.         $30A,$300: result:='Win16 Executable';
  1256.         $0 :result:='Win32 Console Executable';
  1257.       end;
  1258.     end;
  1259.   if Result='' then
  1260.     if GetBinaryType(Pchar(AFilename),Binarytype) then
  1261.       case BinaryType of
  1262.         SCS_32BIT_BINARY: result:= 'Win32 Executable';
  1263.         SCS_DOS_BINARY  : result:= 'DOS Executable';
  1264.         SCS_WOW_BINARY  : result:= 'Win16 Executable';
  1265.         SCS_PIF_BINARY  : result:= 'PIF File';
  1266.         SCS_POSIX_BINARY: result:= 'POSIX Executable';
  1267.         SCS_OS216_BINARY: result:= 'OS/2 16 bit Executable'
  1268.       end;
  1269. end;
  1270.  
  1271. function ExtractUNCFilename;
  1272. var
  1273.   p,l :integer;
  1274. begin
  1275.   p:=pos(':',ASource);
  1276.   if p>0 then begin
  1277.     l:=Length(ASource);
  1278.     result:=Copy(ASource,p-1,l-p+2);
  1279.   end else
  1280.     result:=ASource;
  1281. end;
  1282.  
  1283. function FileCopy;
  1284. var
  1285.   CopyBuffer: Pointer;
  1286.   BytesCopied: Longint;
  1287.   Source, Dest: Integer;
  1288.   Destination: TFileName;
  1289. const
  1290.   ChunkSize: Longint = 8192;
  1291. begin
  1292.   Result:=False;
  1293.   Destination := ExpandFileName(ADestName);
  1294. {  if HasAttr(Destination, faDirectory) then
  1295.     Destination := UniPath(Destination,true) + ExtractFileName(AFileName);}
  1296.   GetMem(CopyBuffer, ChunkSize);
  1297.   try
  1298.     Source:=FileOpen(AFileName, fmShareDenyNone);
  1299.     if not(Source<0) then
  1300.       try
  1301.         Dest:=FileCreate(Destination);
  1302.         if not(Dest<0) then
  1303.           try
  1304.             repeat
  1305.               BytesCopied:=FileRead(Source, CopyBuffer^, ChunkSize);
  1306.               if BytesCopied>0 then
  1307.                  FileWrite(Dest, CopyBuffer^, BytesCopied);
  1308.              until BytesCopied<ChunkSize;
  1309.              Result:=True;
  1310.           finally
  1311.             FileClose(Dest);
  1312.           end;
  1313.         finally
  1314.           FileClose(Source);
  1315.         end;
  1316.   finally
  1317.     FreeMem(CopyBuffer, ChunkSize);
  1318.   end;
  1319. end;
  1320.  
  1321. function FileMove;
  1322. var
  1323.   Destination: string;
  1324. begin
  1325.   Result:=True;
  1326.   Destination := ExpandFileName(ADestName);
  1327.   if not RenameFile(AFileName, Destination) then begin
  1328.     if HasAttr(AFileName, faReadOnly) then begin
  1329.       Result:=False;
  1330.       Exit;
  1331.     end;
  1332.     FileCopy(AFileName, Destination);
  1333.     DeleteFile(AFilename);
  1334.   end;
  1335. end;
  1336.  
  1337. function IsBitOn (Value: Integer; Bit: Byte): Boolean;
  1338. begin
  1339.   Result:=(Value and (1 shl Bit))<>0;
  1340. end;
  1341.  
  1342.  
  1343. function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile,
  1344.    ErrMsg :string): boolean;
  1345. const
  1346.   ROUTINE_ID = '[function: CreateDOSProcessRedirected]';
  1347. var
  1348.   pCommandLine: array[0..MAX_PATH] of char;
  1349.   pInputFile,
  1350.   pOutPutFile: array[0..MAX_PATH] of char;
  1351.   StartupInfo: TStartupInfo;
  1352.   ProcessInfo: TProcessInformation;
  1353.   SecAtrrs: TSecurityAttributes;
  1354.   hAppProcess,
  1355.   hAppThread,
  1356.   hInputFile,
  1357.   hOutputFile   : THandle;
  1358. begin
  1359.   Result := FALSE;
  1360.   if (InputFile<>'') and (not FileExists(InputFile)) then
  1361.     raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
  1362.        'Input file * %s *' + #10 +
  1363.        'does not exist' + #10 + #10 +
  1364.        ErrMsg, [InputFile]);
  1365.   hAppProcess:=0;
  1366.   hAppThread:=0;
  1367.   hInputFile:=0;
  1368.   hOutputFile:=0;
  1369.   try
  1370.     StrPCopy(pCommandLine, CommandLine);
  1371.     StrPCopy(pInputFile, InputFile);
  1372.     StrPCopy(pOutPutFile, OutputFile);
  1373.     { prepare SecAtrrs structure for the CreateFile calls.  This SecAttrs
  1374.       structure is needed in this case because we want the returned handle to
  1375.       be inherited by child process. This is true when running under WinNT.
  1376.       As for Win95, the parameter is ignored. }
  1377.     FillChar(SecAtrrs,SizeOf(SecAtrrs),#0);
  1378.     SecAtrrs.nLength:=SizeOf(SecAtrrs);
  1379.     SecAtrrs.lpSecurityDescriptor:=nil;
  1380.     SecAtrrs.bInheritHandle:=TRUE;
  1381.     if InputFile<>'' then begin
  1382.       hInputFile:=CreateFile(
  1383.          pInputFile,                          { pointer to name of the file }
  1384.          GENERIC_READ or GENERIC_WRITE,       { access (read-write) mode }
  1385.          FILE_SHARE_READ or FILE_SHARE_WRITE, { share mode }
  1386.          @SecAtrrs,                           { pointer to security attributes }
  1387.          OPEN_ALWAYS,                         { how to create }
  1388.          FILE_ATTRIBUTE_NORMAL
  1389.          or FILE_FLAG_WRITE_THROUGH,          { file attributes }
  1390.          0);                                 { handle to file with attrs to copy }
  1391.       if hInputFile = INVALID_HANDLE_VALUE then
  1392.         raise Exception.CreateFmt(ROUTINE_ID + #10 +  #10 +
  1393.            'WinApi function CreateFile returned an invalid handle value' + #10 +
  1394.            'for the input file * %s *' + #10 + #10 +
  1395.             ErrMsg, [InputFile]);
  1396.     end else
  1397.       hInputFile:=0;
  1398.  
  1399.     hOutputFile:=CreateFile(
  1400.        pOutPutFile,                         { pointer to name of the file }
  1401.        GENERIC_READ or GENERIC_WRITE,       { access (read-write) mode }
  1402.        FILE_SHARE_READ or FILE_SHARE_WRITE, { share mode }
  1403.        @SecAtrrs,                           { pointer to security attributes }
  1404.        CREATE_ALWAYS,                       { how to create }
  1405.        FILE_ATTRIBUTE_NORMAL
  1406.        or FILE_FLAG_WRITE_THROUGH,          { file attributes }
  1407.        0 );                                 { handle to file with attrs to copy }
  1408.     if hOutputFile=INVALID_HANDLE_VALUE then
  1409.       raise Exception.CreateFmt(ROUTINE_ID + #10 +  #10 +
  1410.          'WinApi function CreateFile returned an invalid handle value'  + #10 +
  1411.          'for the output file * %s *' + #10 + #10 +
  1412.          ErrMsg, [OutputFile]);
  1413.  
  1414.     FillChar(StartupInfo, SizeOf(StartupInfo), #0);
  1415.     StartupInfo.cb:=SizeOf(StartupInfo);
  1416.     StartupInfo.dwFlags:=STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
  1417.     StartupInfo.wShowWindow:=SW_HIDE;
  1418.     StartupInfo.hStdOutput:=hOutputFile;
  1419.     StartupInfo.hStdInput:=hInputFile;
  1420.  
  1421.     Result:=CreateProcess(
  1422.        NIL,                           { pointer to name of executable module }
  1423.        pCommandLine,                  { pointer to command line string }
  1424.        NIL,                           { pointer to process security attributes }
  1425.        NIL,                           { pointer to thread security attributes }
  1426.        TRUE,                          { handle inheritance flag }
  1427.        HIGH_PRIORITY_CLASS,           { creation flags }
  1428.        NIL,                           { pointer to new environment block }
  1429.        NIL,                           { pointer to current directory name }
  1430.        StartupInfo,                   { pointer to STARTUPINFO }
  1431.        ProcessInfo);                  { pointer to PROCESS_INF }
  1432.  
  1433.     if Result then begin
  1434.       WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
  1435.       hAppProcess:=ProcessInfo.hProcess;
  1436.       hAppThread:=ProcessInfo.hThread;
  1437.     end else
  1438.       raise Exception.Create(ROUTINE_ID + #10 +  #10 +
  1439.          'Function failure'  + #10 +  #10 + ErrMsg);
  1440.   finally
  1441.     if hOutputFile <> 0 then
  1442.       CloseHandle(hOutputFile);
  1443.     if hInputFile <> 0 then
  1444.       CloseHandle(hInputFile);
  1445.     if hAppThread <> 0 then
  1446.       CloseHandle(hAppThread);
  1447.     if hAppProcess <> 0 then
  1448.       CloseHandle(hAppProcess);
  1449.   end;
  1450. end;
  1451.  
  1452. function OpenMailSlot(Const Server, Slot : String): THandle;
  1453. var
  1454.   FullSlot : String;
  1455. begin
  1456.   FullSlot := '\\'+Server+'\mailslot\'+Slot;
  1457.   Result := CreateFile(
  1458.     PChar(FullSlot),
  1459.     GENERIC_WRITE,
  1460.     FILE_SHARE_READ,
  1461.     NIL,
  1462.     OPEN_EXISTING,
  1463.     FILE_ATTRIBUTE_NORMAL,
  1464.     0                    );
  1465. end;
  1466.  
  1467. function SendToMailSlot(Const Server, Slot, Mail : String) : Boolean;
  1468. var
  1469.   hToSlot : THandle;
  1470.   BytesWritten : DWord;
  1471. begin
  1472.   Result := False;
  1473.   hToSlot := OpenMailSlot(Server,Slot);
  1474.   If hToSlot = INVALID_HANDLE_VALUE Then
  1475.     Exit;
  1476.   try
  1477.     BytesWritten := 0;
  1478.     if (NOT WriteFile(hToSlot,
  1479.                       Pointer(Mail)^,
  1480.                       Length(Mail),
  1481.                       BytesWritten,
  1482.                       NIL))         OR
  1483.         (BytesWritten <> Length(Mail)) Then
  1484.       Exit;
  1485.     Result := True;
  1486.   finally
  1487.     CloseHandle(hToSlot);
  1488.   end;
  1489. end;
  1490.  
  1491. function SendToWinpopup(Server, Reciever, Sender, Msg : String) : Boolean;
  1492. var
  1493.   szserver,szsender,szreciever,szmsg :pchar;
  1494. begin
  1495.   szserver:=stralloc(255);
  1496.   szsender:=stralloc(255);
  1497.   szreciever:=stralloc(255);
  1498.   szmsg:=stralloc(255);
  1499.   CharToOEM(PChar(Server),szServer);
  1500.   CharToOEM(PChar(Sender),szSender);
  1501.   CharToOEM(PChar(Reciever),szReciever);
  1502.   CharToOEM(PChar(Msg),szMsg);
  1503.   Result := SendToMailSlot(Server, wpslot, szSender+#0+szReciever+#0+szMsg);
  1504.   strdispose(szserver);
  1505.   strdispose(szsender);
  1506.   strdispose(szreciever);
  1507.   strdispose(szmsg);
  1508. end;
  1509.  
  1510. function EncodeBase (I: Int64; Base: Byte): String;
  1511. var
  1512.   D,J: Int64;
  1513.   N: Byte;
  1514. const ConversionAlphabeth : String [36] = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  1515. begin
  1516.   if I = 0 then begin
  1517.      Result := '0';
  1518.      exit;
  1519.   end;
  1520.   D := Round (Power (Base, Trunc (Log10 (I) / Log10 (Base)) + 1));            // +1 to fix occasional real "fuzz"
  1521.   J := I;
  1522.   Result := '';
  1523.   While D > 0 do begin
  1524.     N := J div D;
  1525.     if (N <> 0) or (Result <> '') then                                      // "fuzz" bug
  1526.       Result := Result + ConversionAlphabeth [N + 1];
  1527.     J := J mod D;
  1528.     D := D div Base;
  1529.   end;
  1530. end;
  1531.  
  1532. function GetFontRes: DWORD;
  1533. var
  1534.   tm: TTextMetric;
  1535.   hwnd,hdc: THandle;
  1536.   MapMode: DWORD;
  1537. begin
  1538.   Result:=0;
  1539.   hwnd:=GetDesktopWindow;
  1540.   hdc:=GetWindowDC(hwnd);
  1541.   if hdc>0 then begin
  1542.     MapMode:=SetMapMode(hdc,MM_TEXT);
  1543.     GetTextMetrics(hdc,tm);
  1544.     SetMapMode(hdc,MapMode);
  1545.     ReleaseDC(hwnd,hdc);
  1546.     Result:=tm.tmHeight;
  1547.   end;
  1548. end;
  1549.  
  1550. function TrimAll;
  1551. var
  1552.   p :integer;
  1553. begin
  1554.   ASource:=trim(ASource);
  1555.   p:=pos(' ',ASource);
  1556.   while p>0 do begin
  1557.     Delete(ASource,p,1);
  1558.     p:=pos(' ',ASource);
  1559.   end;
  1560.   p:=Pos(#13#10,ASource);
  1561.   while p>0 do begin
  1562.     Delete(ASource,p,2);
  1563.     p:=Pos(#13#10,ASource);
  1564.   end;
  1565.   result:=ASource;
  1566. end;
  1567.  
  1568. function booltostr;
  1569. begin
  1570.   if AValue then begin
  1571.     if AVerbose then
  1572.       result:='True'
  1573.     else
  1574.       result:='1';
  1575.   end else begin
  1576.     if AVerbose then
  1577.       result:='False'
  1578.     else
  1579.       result:='0';
  1580.   end;
  1581. end;
  1582.  
  1583. function StrtoBool;
  1584. begin
  1585.   Result:=false;
  1586.   ASource:=UpperCase(ASource);
  1587.   if (ASource='TRUE') or (ASource='1') then
  1588.     Result:=true;
  1589. end;
  1590.  
  1591. procedure AddWord;
  1592. begin
  1593.   if Length(ADest)>0 then
  1594.     ADest:=ADest+ADelimiter+AWord
  1595.   else
  1596.     ADest:=ADest+AWord;
  1597. end;
  1598.  
  1599. function GetDelimitedText;
  1600. var
  1601.   i :integer;
  1602. begin
  1603.   result:='';
  1604.   for i:=0 to AList.Count-1 do
  1605.     Result:=Result+AList[i]+ADelimiter;
  1606.     if Result<>'' then
  1607.       Delete(Result,Length(Result)-Length(ADelimiter)+1,Length(ADelimiter));
  1608. end;
  1609.  
  1610. procedure SetDelimitedText;
  1611. var
  1612.   p: integer;
  1613. begin
  1614.   AList.Clear;
  1615.   p:=Pos(ADelimiter,ASource);
  1616.   while p>0 do begin
  1617.     AList.Add(Copy(ASource,1,p-1));
  1618.     Delete(ASource,1,p+Length(Adelimiter)-1);
  1619.     p:=Pos(ADelimiter,ASource);
  1620.   end;
  1621.   AList.Add(ASource);
  1622. end;
  1623.  
  1624. function FitStr;
  1625. var
  1626.   lf :integer;
  1627.   s :string;
  1628. begin
  1629.   lf:=Length(ASource);
  1630.   if lf>ALength then begin
  1631.     result:=Copy(ASource,1,3);
  1632.     s:=Copy(ASource,lf-ALength+7,lf);
  1633.     result:=Result+AEllipsis+s;
  1634.   end else
  1635.     result:=ASource;
  1636. end;
  1637.  
  1638. function GetToken;
  1639. var
  1640.   i,p :integer;
  1641. begin
  1642.   p:=pos(adelimiter,s);
  1643.   i:=1;
  1644.   while (p>0) and (i<index) do begin
  1645.     inc(i);
  1646.     delete(s,1,p);
  1647.     p:=pos(adelimiter,s);
  1648.   end;
  1649.   result:=copy(s,1,p-1);
  1650. end;
  1651.  
  1652. procedure SetToken;
  1653. var
  1654.   i,p,sx,ex :integer;
  1655.   s1 :string;
  1656. begin
  1657.   s1:=s;
  1658.   p:=pos(adelimiter,s1);
  1659.   sx:=0;
  1660.   i:=0;
  1661.   while (p>0) and (i<index) do begin
  1662.     inc(sx,p);
  1663.     inc(i);
  1664.     delete(s1,1,p);
  1665.     p:=pos(adelimiter,s1);
  1666.   end;
  1667.   ex:=sx+p;
  1668.   s:=copy(s,1,sx)+newvalue+copy(s,ex,255);
  1669. end;
  1670.  
  1671. function ExtractWord;
  1672. Var
  1673.   I,J:Word;
  1674.   Count:Byte;
  1675.   SLen:Integer;
  1676. Begin
  1677.   Count := 0;
  1678.   I := 1;
  1679.   Result := '';
  1680.   SLen := Length(S);
  1681.   While I <= SLen Do Begin
  1682.     While (I <= SLen) And (S[I] In WordDelims) Do Inc(I);
  1683.     If I <= SLen Then Inc(Count);
  1684.     J := I;
  1685.     While (J <= SLen) And Not(S[J] In WordDelims) Do Inc(J);
  1686.     If Count = N Then Begin
  1687.       Result := Copy(S,I,J-I);
  1688.       Exit
  1689.     End;
  1690.     I := J;
  1691.   End;
  1692. end;
  1693.  
  1694. function TestByMask(const S, Mask: string; MaskChar: Char): Boolean;
  1695. asm
  1696.         TEST    EAX,EAX
  1697.         JE      @@qt2
  1698.         PUSH    EBX
  1699.         TEST    EDX,EDX
  1700.         JE      @@qt1
  1701.         MOV     EBX,[EAX-4]
  1702.         CMP     EBX,[EDX-4]
  1703.         JE      @@01
  1704. @@qt1:  XOR     EAX,EAX
  1705.         POP     EBX
  1706. @@qt2:  RET
  1707. @@01:   DEC     EBX
  1708.         JS      @@07
  1709. @@lp:   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.         JS      @@eq
  1724.         MOV     CH,BYTE PTR [EDX+EBX]
  1725.         CMP     CL,CH
  1726.         JNE     @@cm
  1727.         DEC     EBX
  1728.         JNS     @@lp
  1729.         JMP     @@eq
  1730. @@cm:   CMP     CH,BYTE PTR [EAX+EBX]
  1731.         JNE     @@07
  1732.         DEC     EBX
  1733.         JNS     @@lp
  1734. @@eq:   MOV     EAX,1
  1735.         POP     EBX
  1736.         RET
  1737. @@07:   XOR     EAX,EAX
  1738.         POP     EBX
  1739. end;
  1740.  
  1741. function IsLeapYear(Year: Word): Boolean;
  1742. begin
  1743.   Result:=((Year and 3)=0) and ((Year mod 100>0) or (Year mod 400=0));
  1744. end;
  1745.  
  1746. function DaysInMonth(const DT: TDateTime): Byte;
  1747. var
  1748.   y,m,d: Word;
  1749. begin
  1750.   DecodeDate(DT,y,m,d);
  1751.   case m of
  1752.     2: if IsLeapYear(y) then
  1753.          Result:=29
  1754.        else
  1755.          Result:=28;
  1756.     4, 6, 9, 11: Result:=30;
  1757.     else
  1758.       Result := 31;
  1759.   end;
  1760. end;
  1761.  
  1762. function DayOfMonth2Date(year,month,weekInMonth,dayInWeek: word): TDateTime;
  1763. var
  1764.   days: integer;
  1765.   day : integer;
  1766. begin
  1767.   if (weekInMonth>=1) and (weekInMonth<=4) then begin
  1768.     day:=DayOfWeek(EncodeDate(year,month,1));
  1769.     day:=1+dayInWeek-day;
  1770.     if day<=0 then
  1771.       Inc(day,7);
  1772.     day:=day+7*(weekInMonth-1);
  1773.     Result:=EncodeDate(year,month,day);
  1774.   end else
  1775.     if weekInMonth=5 then begin
  1776.       days:=DaysInMonth(EncodeDate(year,month,1));
  1777.       day:=DayOfWeek(EncodeDate(year,month,days));
  1778.       day:=days+(dayInWeek-day);
  1779.       if day>days then
  1780.         Dec(day,7);
  1781.       Result:=EncodeDate(year,month,day);
  1782.     end else
  1783.       Result:=0;
  1784. end;
  1785.  
  1786. function DSTDate2Date(dstDate: TSystemTime; year: word): TDateTime;
  1787. begin
  1788.   if dstDate.wMonth=0 then
  1789.     Result:=0
  1790.   else
  1791.     if dstDate.wYear=0 then
  1792.       Result:=DayOfMonth2Date(year,dstDate.wMonth,dstDate.wDay,dstDate.wDayOfWeek+1)+
  1793.               EncodeTime(dstDate.wHour,dstDate.wMinute,dstDate.wSecond,dstDate.wMilliseconds)
  1794.     else
  1795.       Result:=SystemTimeToDateTime(dstDate);
  1796. end;
  1797.  
  1798. function GetOpenFileDlg;
  1799. begin
  1800.   if ADir='' then
  1801.     ADir:=ExtractFilePath(ParamStr(0));
  1802.   StrPCopy(PChar(@buffer),FileName);
  1803.   ofn.lStructSize:=SizeOf(TOpenFilename);
  1804.   ofn.hWndOwner:=AHandle;
  1805.   ofn.hInstance:=HInstance;
  1806.   ofn.lpstrFilter:=PChar(AFilter);
  1807.   ofn.lpstrFile:=buffer;
  1808.   ofn.nMaxFile:=MAXSIZE;
  1809.   ofn.lpstrTitle:=PChar(ATitle);
  1810.   ofn.lpstrInitialDir:=PChar(ADir);
  1811.   if AOpenDlg then begin
  1812.     ofn.Flags:=OFN_FILEMUSTEXIST or OFN_PATHMUSTEXIST or
  1813.                OFN_LONGNAMES or OFN_EXPLORER or OFN_HIDEREADONLY;
  1814.     Result:=GetOpenFileName(ofn);
  1815.   end else begin
  1816.     ofn.Flags:=OFN_PATHMUSTEXIST or OFN_OVERWRITEPROMPT or
  1817.                OFN_LONGNAMES or OFN_EXPLORER or OFN_HIDEREADONLY;
  1818.     Result:=GetSaveFileName(ofn);
  1819.   end;
  1820.   Filename:=buffer;
  1821. end;
  1822.  
  1823. initialization
  1824.   Os:=GetOS;
  1825.   IsNT:=OS in [osNT3,osNT4,os2K];
  1826.   IS95:=OS=os95;
  1827.   Is98:=OS=os98;
  1828.   Is2K:=OS=os2K;
  1829.   IsOSR2:=OS=os95OSR2;
  1830.   IsSE:=OS=os98SE;
  1831.   IsME:=OS=osME;
  1832.   IsXP:=OS=osXP;
  1833.   WindowsUser:=GetUser;
  1834.   MachineName:=GetMachine;
  1835.   ProfilePath:=GetProfilePath;
  1836.   case OS of
  1837.     os95, os95OSR2: OSVersion:='Windows 95';
  1838.     os98, os98SE: OSVersion:='Windows 98';
  1839.     osME: OSVersion:='Windows Millenium Edition';
  1840.     osNT3, osNT4: OSVersion:='Windows NT';
  1841.     os2K: OSVersion:='Windows 2000';
  1842.     osXP: OSVersion:='Windows XP';
  1843.   end;
  1844.   if IsNT then
  1845.     ClassKey:='SYSTEM\CurrentControlSet\Control\Class'
  1846.   else
  1847.     ClassKey:='SYSTEM\CurrentControlSet\Services\Class';
  1848. end.
  1849.