UtilsDos.pas 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895
  1. unit UtilsDos;
  2. interface
  3. uses
  4. WinProcs, WinTypes, SysUtils, Classes;
  5. type
  6. TByteFile = file of Byte;
  7. TDrive = 'A'..'Z';
  8. TDrives = set of TDrive;
  9. function UCase (NormalChar: Char): Char;
  10. function LCase (NormalChar: Char): Char;
  11. function IsNormalChar (Ch: Char): Boolean;
  12. function ChangeText (var ChText: string; ToChange, ToInsert: string): Byte;
  13. function LastPos (const Substr, S: string): Integer;
  14. function PosEx (const Substr, S: string; StartPos: Integer; Backwards: Boolean = False): Integer;
  15. function FirstNonWhiteSpace (const S: string): Integer;
  16. function GetDriveDescription (Drive: TDrive): string;
  17. function DiskInDrive (Drive: TDrive): Boolean;
  18. function FileExistsWithCase (const FileName: string): Boolean;
  19. function DirExists (const Directory: string): Boolean;
  20. function DirExistsWithCase (const Directory: string): Boolean;
  21. function GetFileSize (const FileName: string): Integer;
  22. function GetSubDir (const Directory: string): string;
  23. function GetHigherDir (const Directory: string): string;
  24. function GetLowerName (const N: string): string;
  25. function SizeToStr (Size: Int64): string;
  26. function AttrToStr (Attr: Integer): string;
  27. procedure CreatePath (const Directory: string);
  28. procedure CreatePathFor (const FileName: string);
  29. procedure RemovePath (const Directory: string; const StopAt: string = '');
  30. procedure RemovePathFor (const FileName: string; const StopAt: string = '');
  31. procedure DelTree (const Directory: string);
  32. procedure DelAllFiles (const Directory: string);
  33. procedure PCSpeakerPlay (Frequency: Word);
  34. procedure PCSpeakerStop;
  35. procedure SetDate (a: Word; m, d: Byte);
  36. procedure SetTime (h, m, s, hs: Byte);
  37. procedure WrCStr (var F: TByteFile; Str: string);
  38. procedure WrPStr (var F: TByteFile; Str: string; Len: Byte);
  39. procedure WrVStr (var F: TByteFile; Str: string);
  40. procedure WrSInt (var F: TByteFile; Value: ShortInt);
  41. procedure WrByte (var F: TByteFile; Value: Byte);
  42. procedure WrNInt (var F: TByteFile; Value: SmallInt);
  43. procedure WrWord (var F: TByteFile; Value: Word);
  44. procedure RdCStr (var F: TByteFile; var Str: string; Len: Byte);
  45. procedure RdPStr (var F: TByteFile; var Str: string; Len: Byte);
  46. procedure RdVStr (var F: TByteFile; var Str: string);
  47. procedure RdSInt (var F: TByteFile; var Value: ShortInt);
  48. procedure RdByte (var F: TByteFile; var Value: Byte);
  49. procedure RdNInt (var F: TByteFile; var Value: SmallInt);
  50. procedure RdWord (var F: TByteFile; var Value: Word);
  51. type
  52. TFileAttribute = (atDirectory, atArchive, atReadOnly, atHidden, atSystem);
  53. // atDirectory only for internal use and property request
  54. TFileAttributes = set of TFileAttribute;
  55. const
  56. atStd: TFileAttributes = [atArchive, atReadOnly];
  57. atAll: TFileAttributes = [atArchive, atReadOnly, atHidden, atSystem];
  58. type
  59. TFileReferences = class;
  60. TFileReference = class(TPersistent)
  61. private
  62. FOwner: TFileReferences;
  63. FSearchRec: TSearchRec;
  64. function GetCreationTime: TDateTime;
  65. function GetFileAttr: TFileAttributes;
  66. function GetFileName: string;
  67. function GetFileSize: Integer;
  68. function GetFullName: string;
  69. function GetFullShortName: string;
  70. function GetLastAccessTime: TDateTime;
  71. function GetModificationTime: TDateTime;
  72. function GetShortFileName: string;
  73. public
  74. published
  75. property Owner: TFileReferences read FOwner;
  76. property RecData: TSearchRec read FSearchRec;
  77. property FullName: string read GetFullName;
  78. property FileName: string read GetFileName;
  79. property FullShortName: string read GetFullShortName;
  80. property ShortFileName: string read GetShortFileName;
  81. property CreationTime: TDateTime read GetCreationTime;
  82. property ModificationTime: TDateTime read GetModificationTime;
  83. property LastAccessTime: TDateTime read GetLastAccessTime;
  84. property FileSize: Integer read GetFileSize;
  85. property FileAttr: TFileAttributes read GetFileAttr;
  86. end;
  87. TFileReferences = class(TPersistent)
  88. private
  89. FList: TList;
  90. FDirectory: string;
  91. FWildCard: string;
  92. FSearchAttr: TFileAttributes;
  93. FSearchTime: TDateTime;
  94. function GetItem(ItemIndex: Integer): TFileReference;
  95. function GetCount: Integer;
  96. public
  97. constructor Create;
  98. destructor Destroy; override;
  99. function Add(const F: TSearchRec): Integer; virtual;
  100. procedure Delete(Index: Integer); virtual;
  101. procedure Clear;
  102. procedure SearchForFiles(FileName: string; FileAttr: TFileAttributes);
  103. procedure SearchForDirs(const ParentDir: string; FileAttr: TFileAttributes);
  104. procedure CopyToStrings(const S: TStrings);
  105. procedure CopyFullNamesToStrings(const S: TStrings);
  106. property Items[ItemIndex: Integer]: TFileReference read GetItem;
  107. property Count: Integer read GetCount;
  108. published
  109. property Directory: string read FDirectory;
  110. property WildCard: string read FWildCard;
  111. property SearchAttr: TFileAttributes read FSearchAttr;
  112. property SearchTime: TDateTime read FSearchTime;
  113. end;
  114. function WinFileTimeToDateTime(WinFileTime: TFileTime): TDateTime;
  115. function WinFileAttrToFileAttr(WinFileAttr: Integer): TFileAttributes;
  116. function FileAttrToWinFileAttr(FileAttr: TFileAttributes): Integer;
  117. procedure AddBackslash(var Dir: string);
  118. function WithBackslash(const Dir: string): string;
  119. function WithoutBackslash(const Dir: string): string;
  120. function WithoutExt(const FileName: string): string;
  121. implementation
  122. function UCase;
  123. begin
  124. Result := UpCase (NormalChar);
  125. case Result of
  126. 'ä': Result := 'Ä';
  127. 'ö': Result := 'Ö';
  128. 'ü': Result := 'Ü';
  129. end;
  130. end;
  131. function LCase;
  132. begin
  133. Result := LowerCase (NormalChar) [1];
  134. case Result of
  135. 'Ä': Result := 'ä';
  136. 'Ö': Result := 'ö';
  137. 'Ü': Result := 'ü';
  138. end;
  139. end;
  140. function IsNormalChar;
  141. begin
  142. Result := UCase (Ch) <> LCase (Ch);
  143. end;
  144. function LastPos;
  145. var
  146. I: Integer;
  147. begin
  148. Result := 0;
  149. for I := Length (S) - Length (Substr) + 1 downto 1 do
  150. if Copy (S, I, Length (Substr)) = Substr then begin
  151. Result := I;
  152. Break;
  153. end;
  154. end;
  155. function PosEx;
  156. var
  157. I: Integer;
  158. begin
  159. Result := 0;
  160. if Backwards then begin
  161. for I := StartPos downto 1 do
  162. if Copy (S, I, Length (Substr)) = Substr then begin
  163. Result := I;
  164. Break;
  165. end;
  166. end else begin
  167. for I := StartPos to Length (S) - Length (Substr) + 1 do
  168. if Copy (S, I, Length (Substr)) = Substr then begin
  169. Result := I;
  170. Break;
  171. end;
  172. end;
  173. end;
  174. function FirstNonWhiteSpace;
  175. var
  176. I: Integer;
  177. begin
  178. Result := Length (S) + 1;
  179. for I := 1 to Length (S) do
  180. if not (S [I] in [' ', #9]) then begin
  181. Result := I;
  182. Break;
  183. end;
  184. end;
  185. function GetDriveDescription;
  186. var
  187. F: Text;
  188. R,
  189. N: array [0..255] of Char;
  190. V: DWord;
  191. begin
  192. Result := '';
  193. if FileExists (Drive + ':\DiskID.clk') then begin
  194. AssignFile (F, Drive + ':\DiskID.clk');
  195. Reset (F);
  196. ReadLn (F, Result);
  197. CloseFile (F);
  198. end else begin
  199. StrPCopy (R, Drive + ':\');
  200. if GetVolumeInformation (R, N, 255, nil, V, V, nil, 0) then
  201. Result := StrPas (N);
  202. end;
  203. if Result = '' then
  204. Result := Drive + ':\';
  205. Result := GetLowerName (Result);
  206. end;
  207. function DiskInDrive;
  208. var
  209. V: DWord;
  210. begin
  211. Result := GetDiskFreeSpace (PChar (Drive + ':\'), V, V, V, V);
  212. end;
  213. procedure CreatePath;
  214. var
  215. SeedPath: string;
  216. CurPath: string;
  217. begin
  218. SeedPath := WithBackslash (Directory);
  219. CurPath := '';
  220. while Pos ('\', SeedPath) > 0 do begin
  221. CurPath := CurPath + Copy (SeedPath, 1, Pos ('\', SeedPath));
  222. Delete (SeedPath, 1, Pos ('\', SeedPath));
  223. if Length (CurPath) > 3 then
  224. if not DirExists (CurPath) then try
  225. MkDir (CurPath);
  226. except end;
  227. end;
  228. end;
  229. procedure CreatePathFor;
  230. begin
  231. CreatePath (ExtractFilePath (FileName));
  232. end;
  233. procedure RemovePath;
  234. var
  235. Dir: string;
  236. S: TSearchRec;
  237. Found: Boolean;
  238. begin
  239. Dir := WithBackslash (Directory);
  240. if (Length (Dir) > 3) and (Dir <> WithBackslash (StopAt)) and DirExists (Dir) then begin
  241. Found := False;
  242. if FindFirst (Dir + '*', faAnyFile, S) = 0 then begin
  243. repeat
  244. if (S.Name <> '.') and (S.Name <> '..') then
  245. Found := True;
  246. until (FindNext (S) <> 0) or Found;
  247. end;
  248. FindClose (S);
  249. if not Found then try
  250. RmDir (Dir);
  251. RemovePath (GetHigherDir (Directory), StopAt);
  252. except end;
  253. end;
  254. end;
  255. procedure RemovePathFor;
  256. begin
  257. RemovePath (ExtractFilePath (FileName), StopAt);
  258. end;
  259. procedure DelTree;
  260. var
  261. CurDelDir: string;
  262. begin
  263. CurDelDir := WithBackslash (Directory);
  264. repeat
  265. while GetSubDir (CurDelDir) <> '' do begin
  266. CurDelDir := CurDelDir + GetSubDir
  267. (CurDelDir) + '\';
  268. end;
  269. DelAllFiles (CurDelDir);
  270. if Length (CurDelDir) < 4 then
  271. RmDir (CurDelDir)
  272. else
  273. RmDir (Copy (CurDelDir, 1, Length (CurDelDir) - 1));
  274. CurDelDir := GetHigherDir (CurDelDir);
  275. until CurDelDir = GetHigherDir (Directory);
  276. end;
  277. function FileExistsWithCase;
  278. var
  279. S: TSearchRec;
  280. begin
  281. Result := (FindFirst (FileName, faAnyFile, S) = 0);
  282. if Result and (S.Name <> ExtractFileName (FileName)) then
  283. Result := False;
  284. FindClose (S);
  285. end;
  286. function DirExists;
  287. var
  288. S: TSearchRec;
  289. begin
  290. Result := (FindFirst (WithoutBackslash (Directory), faDirectory or faHidden or faSysFile, S) = 0);
  291. FindClose (S);
  292. end;
  293. function DirExistsWithCase;
  294. var
  295. S: TSearchRec;
  296. begin
  297. Result := (FindFirst (WithoutBackslash (Directory), faDirectory, S) = 0);
  298. if Result and (S.Name <> ExtractFileName (WithoutBackslash (Directory))) then
  299. Result := False;
  300. FindClose (S);
  301. end;
  302. function GetFileSize;
  303. var
  304. S: TSearchRec;
  305. begin
  306. if FindFirst (FileName, faAnyFile, S) = 0 then
  307. Result := S.Size
  308. else
  309. Result := 0;
  310. FindClose (S);
  311. end;
  312. function GetSubDir;
  313. var
  314. SR1: TSearchRec;
  315. GoOn: Boolean;
  316. begin
  317. GoOn := True;
  318. if FindFirst (Directory + '*.*', $10, SR1) = 0 then begin
  319. while GoOn and (((SR1.Attr and $10) = 0) or (SR1.Name = '.') or (SR1.Name = '..')) do begin
  320. if FindNext (SR1) <> 0 then begin
  321. SR1.Name := '';
  322. GoOn := False;
  323. end;
  324. end;
  325. GetSubDir := SR1.Name
  326. end else
  327. GetSubDir := '';
  328. FindClose (SR1);
  329. end;
  330. function GetHigherDir;
  331. begin
  332. Result := ExtractFilePath (WithoutBackslash (Directory));
  333. end;
  334. procedure DelAllFiles;
  335. var
  336. SR1: TSearchRec;
  337. begin
  338. if FindFirst (Directory + '*.*', $20, SR1) = 0 then begin
  339. SysUtils.DeleteFile (Directory + SR1.Name);
  340. while FindNext (SR1) = 0 do
  341. SysUtils.DeleteFile (Directory + SR1.Name);
  342. end;
  343. FindClose (SR1);
  344. end;
  345. function GetLowerName;
  346. var
  347. I: Integer;
  348. begin
  349. Result := N;
  350. if (Length (Result) > 0) and ((Result = UpperCase (Result)) or (Result = LowerCase (Result))) then begin
  351. Result := UpperCase (Result);
  352. for I := 2 to Length (Result) do begin
  353. if IsNormalChar (Result [I-1]) then
  354. Result [I] := LCase (Result [I]);
  355. end;
  356. end;
  357. end;
  358. function SizeToStr;
  359. var
  360. Sz: Real;
  361. M: Byte;
  362. begin
  363. M := 0;
  364. Sz := Size;
  365. while Sz >= 1000 do begin
  366. Sz := Sz / 1000;
  367. Inc (M);
  368. end;
  369. Result := FloatToStr (Sz);
  370. if Length (Result) > 4 then
  371. Result := Copy (Result, 1, 4);
  372. if Result [Length (Result)] = DecimalSeparator then
  373. Delete (Result, Length (Result), 1);
  374. case M of
  375. 0: Result := Result + ' B';
  376. 1: Result := Result + ' KB';
  377. 2: Result := Result + ' MB';
  378. 3: Result := Result + ' GB';
  379. 4: Result := Result + ' TB';
  380. else Result := Result + '...';
  381. end;
  382. end;
  383. function AttrToStr;
  384. begin
  385. Result := '';
  386. if (Attr and faArchive) <> 0 then Result := Result + 'A';
  387. if (Attr and faReadOnly) <> 0 then Result := Result + 'R';
  388. if (Attr and faHidden) <> 0 then Result := Result + 'H';
  389. if (Attr and faSysFile) <> 0 then Result := Result + 'S';
  390. end;
  391. function ChangeText;
  392. var
  393. TxtPs: Byte;
  394. begin
  395. TxtPs := 0;
  396. while Pos (ToChange, ChText) <> 0 do begin
  397. TxtPs := Pos (ToChange, ChText);
  398. Delete (Chtext, TxtPs, Length (ToChange));
  399. Insert (ToInsert, ChText, TxtPs);
  400. end;
  401. ChangeText := TxtPs;
  402. end;
  403. procedure PCSpeakerPlay (Frequency: Word); assembler;
  404. asm
  405. Mov BX, Frequency
  406. Mov AX, $34DD
  407. Mov DX, $0012
  408. Cmp DX, BX
  409. Jnb @EndOfProc
  410. Div BX
  411. Mov BX, AX
  412. In AL, $61
  413. Test AL, $03
  414. Jne @NearlyEndOfProc
  415. Or AL, $03
  416. Out $61, AL
  417. Mov AL, $B6
  418. Out $43, AL
  419. @NearlyEndOfProc:
  420. Mov AL, BL
  421. Out $42, AL
  422. Mov AL, BH
  423. Out $42, AL
  424. @EndOfProc:
  425. end;
  426. procedure PCSpeakerStop; assembler;
  427. asm
  428. In AL, $61
  429. And AL, $FC
  430. Out $61, AL
  431. end;
  432. procedure SetDate; assembler;
  433. asm
  434. Mov CX, a
  435. Mov DH, m
  436. Mov DL, d
  437. Mov AH, $2B
  438. Int $21
  439. end;
  440. procedure SetTime; assembler;
  441. asm
  442. Mov CH, h
  443. Mov CL, m
  444. Mov DH, s
  445. Mov DL, hs
  446. Mov AH, $2D
  447. Int $21
  448. end;
  449. procedure WrCStr;
  450. var
  451. VLp1,
  452. VHlp: Byte;
  453. begin
  454. for VLp1 := 1 to Length (Str) do begin
  455. VHlp := Ord (Str [VLp1]);
  456. Write (F, VHlp);
  457. end;
  458. end;
  459. procedure WrPStr;
  460. var
  461. VLp1,
  462. VHlp,
  463. VHp2: Byte;
  464. begin
  465. VHlp := Length (Str);
  466. if VHlp > Len then VHlp := Len;
  467. Write (F, VHlp);
  468. for VLp1 := 1 to VHlp do begin
  469. VHp2 := Ord (Str [VLp1]);
  470. Write (F, VHp2);
  471. end;
  472. VHp2 := 0;
  473. for VLp1 := VHlp + 1 to Len do Write (F, VHp2);
  474. end;
  475. procedure WrVStr;
  476. var
  477. VLp1,
  478. VHlp: Byte;
  479. begin
  480. VHlp := Length (Str);
  481. Write (F, VHlp);
  482. for VLp1 := 1 to VHlp do begin
  483. VHlp := Ord (Str [VLp1]);
  484. Write (F, VHlp);
  485. end;
  486. end;
  487. procedure WrSInt;
  488. var
  489. VHlp: Byte;
  490. begin
  491. VHlp := Byte (Value);
  492. Write (F, VHlp);
  493. end;
  494. procedure WrByte;
  495. var
  496. VHlp: Byte;
  497. begin
  498. VHlp := Value;
  499. Write (F, VHlp);
  500. end;
  501. procedure WrNInt;
  502. var
  503. VHlp: Byte;
  504. begin
  505. VHlp := Hi (Word (Value));
  506. Write (F, VHlp);
  507. VHlp := Lo (Word (Value));
  508. Write (F, VHlp);
  509. end;
  510. procedure WrWord;
  511. var
  512. VHlp: Byte;
  513. begin
  514. VHlp := Hi (Value);
  515. Write (F, VHlp);
  516. VHlp := Lo (Value);
  517. Write (F, VHlp);
  518. end;
  519. procedure RdCStr;
  520. var
  521. VLp1,
  522. VHlp: Byte;
  523. begin
  524. Str := '';
  525. for VLp1 := 1 to Len do begin
  526. Read (F, VHlp);
  527. Str := Str + Chr (VHlp);
  528. end;
  529. end;
  530. procedure RdPStr;
  531. var
  532. FPos,
  533. VLp1,
  534. VHlp: Byte;
  535. begin
  536. FPos := FilePos (F);
  537. Str := '';
  538. Read (F, VHlp);
  539. for VLp1 := 1 to VHlp do begin
  540. Read (F, VHlp);
  541. Str := Str + Chr (VHlp);
  542. end;
  543. Seek (F, FPos + Len + 1);
  544. end;
  545. procedure RdVStr;
  546. var
  547. VLp1,
  548. VHlp: Byte;
  549. begin
  550. Str := '';
  551. Read (F, VHlp);
  552. for VLp1 := 1 to VHlp do begin
  553. Read (F, VHlp);
  554. Str := Str + Chr (VHlp);
  555. end;
  556. end;
  557. procedure RdSInt;
  558. var
  559. VHlp: Byte;
  560. begin
  561. Read (F, VHlp);
  562. Value := ShortInt (VHlp);
  563. end;
  564. procedure RdByte;
  565. begin
  566. Read (F, Value);
  567. end;
  568. procedure RdNInt;
  569. var
  570. VHlp1: Byte;
  571. VHlp2: Word;
  572. begin
  573. Read (F, VHlp1);
  574. VHlp2 := VHlp1 * 256;
  575. Read (F, VHlp1);
  576. Inc (VHlp2, VHlp1);
  577. Value := SmallInt (VHlp2);
  578. end;
  579. procedure RdWord;
  580. var
  581. VHlp: Byte;
  582. begin
  583. Read (F, VHlp);
  584. Value := VHlp * 256;
  585. Read (F, VHlp);
  586. Inc (Value, VHlp);
  587. end;
  588. function WinFileTimeToDateTime(WinFileTime: TFileTime): TDateTime;
  589. var
  590. Time: Integer;
  591. LocalFileTime: TFileTime;
  592. begin
  593. FileTimeToLocalFileTime(WinFileTime, LocalFileTime);
  594. FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo);
  595. Result := FileDateToDateTime (Time);
  596. end;
  597. function WinFileAttrToFileAttr(WinFileAttr: Integer): TFileAttributes;
  598. begin
  599. Result := [];
  600. if (WinFileAttr and faDirectory) <> 0 then
  601. Include (Result, atDirectory);
  602. if (WinFileAttr and faArchive) <> 0 then
  603. Include (Result, atArchive);
  604. if (WinFileAttr and faReadOnly) <> 0 then
  605. Include (Result, atReadOnly);
  606. if (WinFileAttr and faHidden) <> 0 then
  607. Include (Result, atHidden);
  608. if (WinFileAttr and faSysFile) <> 0 then
  609. Include (Result, atSystem);
  610. end;
  611. function FileAttrToWinFileAttr(FileAttr: TFileAttributes): Integer;
  612. begin
  613. Result := 0;
  614. if atDirectory in FileAttr then
  615. Result := Result or faDirectory;
  616. if atArchive in FileAttr then
  617. Result := Result or faArchive;
  618. if atReadOnly in FileAttr then
  619. Result := Result or faReadOnly;
  620. if atHidden in FileAttr then
  621. Result := Result or faHidden;
  622. if atSystem in FileAttr then
  623. Result := Result or faSysFile;
  624. end;
  625. procedure AddBackslash(var Dir: string);
  626. begin
  627. if (Length (Dir) > 0) and (Dir [Length (Dir)] <> '\') then
  628. Dir := Dir + '\';
  629. end;
  630. function WithBackslash(const Dir: string): string;
  631. begin
  632. if (Length (Dir) > 0) and (Dir [Length (Dir)] <> '\') then
  633. Result := Dir + '\'
  634. else
  635. Result := Dir;
  636. end;
  637. function WithoutBackslash(const Dir: string): string;
  638. begin
  639. if (Length (Dir) > 0) and (Length (Dir) > 3) and (Dir [Length (Dir)] = '\') then
  640. Result := Copy (Dir, 1, Length (Dir) - 1)
  641. else
  642. Result := Dir;
  643. end;
  644. function WithoutExt(const FileName: string): string;
  645. begin
  646. Result := ChangeFileExt (FileName, '');
  647. end;
  648. { TFileReference }
  649. function TFileReference.GetCreationTime: TDateTime;
  650. begin
  651. Result := WinFileTimeToDateTime (FSearchRec.FindData.ftCreationTime);
  652. end;
  653. function TFileReference.GetFileAttr: TFileAttributes;
  654. begin
  655. Result := WinFileAttrToFileAttr (FSearchRec.Attr);
  656. end;
  657. function TFileReference.GetFileName: string;
  658. begin
  659. Result := FSearchRec.Name;
  660. end;
  661. function TFileReference.GetFileSize: Integer;
  662. begin
  663. Result := FSearchRec.Size;
  664. end;
  665. function TFileReference.GetFullName: string;
  666. begin
  667. Result := FOwner.Directory + FSearchRec.Name;
  668. end;
  669. function TFileReference.GetFullShortName: string;
  670. var
  671. TmpDir: string;
  672. F: TSearchRec;
  673. begin
  674. Result := ShortFileName;
  675. TmpDir := FOwner.Directory;
  676. Delete (TmpDir, Length (TmpDir), 1);
  677. while Length (TmpDir) > 2 do begin
  678. if FindFirst (TmpDir, faDirectory or faReadOnly or faHidden or faSysFile or faArchive, F) = 0 then begin
  679. if F.FindData.cAlternateFileName = '' then
  680. Result := F.Name + '\' + Result
  681. else
  682. Result := F.FindData.cAlternateFileName + '\' + Result
  683. end else
  684. Result := ExtractFileName (TmpDir) + '\' + Result;
  685. FindClose (F);
  686. Delete (TmpDir, LastPos ('\', TmpDir), Length (TmpDir));
  687. end;
  688. Result := TmpDir + '\' + Result;
  689. end;
  690. function TFileReference.GetLastAccessTime: TDateTime;
  691. begin
  692. Result := WinFileTimeToDateTime (FSearchRec.FindData.ftLastAccessTime);
  693. end;
  694. function TFileReference.GetModificationTime: TDateTime;
  695. begin
  696. Result := WinFileTimeToDateTime (FSearchRec.FindData.ftLastWriteTime);
  697. end;
  698. function TFileReference.GetShortFileName: string;
  699. begin
  700. Result := FSearchRec.FindData.cAlternateFileName;
  701. if Result = '' then
  702. Result := FSearchRec.Name;
  703. end;
  704. { TFileReferences }
  705. function TFileReferences.Add(const F: TSearchRec): Integer;
  706. var
  707. R: TFileReference;
  708. begin
  709. R := TFileReference.Create;
  710. with R do begin
  711. FOwner := Self;
  712. FSearchRec := F;
  713. end;
  714. Result := FList.Add (Pointer (R));
  715. end;
  716. procedure TFileReferences.Clear;
  717. begin
  718. while Count > 0 do
  719. Delete (Count - 1);
  720. end;
  721. procedure TFileReferences.CopyFullNamesToStrings(const S: TStrings);
  722. var
  723. I: Integer;
  724. begin
  725. S.BeginUpdate;
  726. for I := 0 to Count - 1 do
  727. S.AddObject (Items[I].FullName, Items [I]);
  728. S.EndUpdate;
  729. end;
  730. procedure TFileReferences.CopyToStrings(const S: TStrings);
  731. var
  732. I,
  733. P: Integer;
  734. N: string;
  735. begin
  736. S.BeginUpdate;
  737. for I := 0 to Count - 1 do begin
  738. N := Items[I].FileName;
  739. P := LastPos ('.', N);
  740. if P < 1 then
  741. P := Length (N)
  742. else
  743. Dec (P);
  744. S.AddObject (GetLowerName (Copy (N, 1, P)), Items [I]);
  745. end;
  746. S.EndUpdate;
  747. end;
  748. constructor TFileReferences.Create;
  749. begin
  750. inherited;
  751. FList := TList.Create;
  752. end;
  753. procedure TFileReferences.Delete(Index: Integer);
  754. begin
  755. with FList do begin
  756. TFileReference(Items[Index]).Free;
  757. Delete (Index);
  758. end;
  759. end;
  760. destructor TFileReferences.Destroy;
  761. begin
  762. inherited;
  763. Clear;
  764. FList.Free;
  765. end;
  766. function TFileReferences.GetCount: Integer;
  767. begin
  768. Result := FList.Count;
  769. end;
  770. function TFileReferences.GetItem(ItemIndex: Integer): TFileReference;
  771. begin
  772. Result := TFileReference (FList.Items [ItemIndex]);
  773. end;
  774. procedure TFileReferences.SearchForDirs(const ParentDir: string;
  775. FileAttr: TFileAttributes);
  776. var
  777. Mask: string;
  778. begin
  779. if Length (ParentDir) > 0 then
  780. Mask := WithBackslash (ParentDir)
  781. else
  782. Mask := '*.*';
  783. SearchForFiles (Mask, FileAttr + [atDirectory]);
  784. end;
  785. procedure TFileReferences.SearchForFiles(FileName: string;
  786. FileAttr: TFileAttributes);
  787. var
  788. F: TSearchRec;
  789. R: Integer;
  790. begin
  791. Clear;
  792. if (FileName = '') or (FileName [Length (FileName)] = '\') then
  793. FileName := FileName + '*.*';
  794. FileName := ExpandFileName (FileName);
  795. FDirectory := ExtractFilePath (FileName);
  796. FWildCard := ExtractFileName (FileName);
  797. FSearchAttr := FileAttr;
  798. R := FindFirst (FileName, FileAttrToWinFileAttr (FileAttr), F);
  799. while R = 0 do begin
  800. if (not ((atDirectory in FileAttr) and ((faDirectory and F.Attr) = 0))) and (F.Name [1] <> '.') and ((WinFileAttrToFileAttr (F.Attr) - FileAttr) = []) then
  801. Add (F);
  802. R := FindNext (F);
  803. end;
  804. FindClose (F);
  805. FSearchTime := Now;
  806. end;
  807. end.