Login | ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/indexer_suite/trunk/IndexCreatorForm.pas
Revision: 6
Committed: Tue Dec 11 23:24:20 2018 UTC (2 years, 9 months ago) by daniel-marschall
Content type: text/x-pascal
File size: 26195 byte(s)

File Contents

# Content
1 unit IndexCreatorForm;
2
3 // TODO: vor einem fehler bitte vorher einen löschvorgang durchführen --> geht nicht?
4 // TODO: berücksichtigen, wenn datei gesperrt. etc, fehler anschauen
5 // TODO: warum sind in der db mehr einträge als dateien auf der festplatte sind?!
6 // TODO: Möglichkeit geben, Dateien und Verzeichnisse auszuschließen
7 // TODO: should we include flags (readonly, invisible, compressed, encrypted)?
8 // TODO: search+replace tool, wenn man große verschiebungen vorgenommen hat
9 // update top (100000) files set filename = replace(filename, '\\?\Volume{560e8251-2b6a-4ab7-82fc-d03df4d93538}\', 'EHDD:\') where filename like '%\\?\%';
10 // TODO: anzeige, wie viele stunden der prozess schon läuft
11 // TODO: multithreading
12 // TODO: diverse tools schreiben, die die datenbank nutzen, z.b. ein tool, das prüft, ob ein verzeichnis vollständig redundant ist
13 // TODO: Beim Lauf F:\nas\data wurden 1312 Fehler gefunden, aber nicht geloggt! ?! Eine exception im exception handler?!
14 // => nochmal durchlaufen lassen
15 // TODO: "Laufwerk" EHDD: soll man auch eingeben dürfen (das ist z.b. wichtig, wenn man Querverknüpfung vom Explorer verwendet)
16 // TODO: validate modus auch ohne prüfsummencheck. nur gucken ob die dateien existieren
17
18 {$DEFINE VIATHINKSOFT}
19
20 interface
21
22 uses
23 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
24 Dialogs, StdCtrls, ComCtrls, ExtCtrls, DB, ADODB, Menus;
25
26 const
27 modusUpdate = 0;
28 modusRecreate = 1;
29 modusValidation = 2;
30
31 type
32 TfrmIndexCreator = class(TForm)
33 Button1: TButton;
34 Label1: TLabel;
35 LabeledEdit2: TLabeledEdit;
36 Button2: TButton;
37 Label2: TLabel;
38 Label3: TLabel;
39 Label4: TLabel;
40 Label5: TLabel;
41 Label6: TLabel;
42 Label7: TLabel;
43 PopupMenu1: TPopupMenu;
44 Copyuniquepathtoclipboard1: TMenuItem;
45 Label8: TLabel;
46 Label9: TLabel;
47 Label10: TLabel;
48 Label11: TLabel;
49 Label12: TLabel;
50 Label13: TLabel;
51 Memo1: TMemo;
52 Button4: TButton;
53 Label14: TLabel;
54 cbNoDelete: TCheckBox;
55 Memo2: TMemo;
56 cbVerboseLogs: TCheckBox;
57 cbSimulate: TCheckBox;
58 rgModus: TRadioGroup;
59 procedure Button1Click(Sender: TObject);
60 procedure FormClose(Sender: TObject; var Action: TCloseAction);
61 procedure Button2Click(Sender: TObject);
62 procedure FormShow(Sender: TObject);
63 procedure Copyuniquepathtoclipboard1Click(Sender: TObject);
64 procedure Button4Click(Sender: TObject);
65 procedure rgModusClick(Sender: TObject);
66 private
67 StopRequest: boolean;
68 sumsize: int64;
69 sumfiles: int64;
70 sumfiles_new: int64;
71 sumfiles_updated: int64;
72 sumfiles_error: int64;
73 sumfiles_deleted: int64;
74 sumfiles_integrityfail: int64;
75 function TableName: string;
76 function conn: TAdoConnection;
77 procedure Rec(StartDir: string; const FileMask: string);
78 procedure CheckFile(const originalFileName, uniqueFilename: string);
79 procedure EnableDisableControls(enabled: boolean);
80 procedure IndexDrive(initialdir: string);
81 procedure RedrawStats;
82 procedure DeleteVanishedFiles(mask: string = '');
83 class function DriveGuid(const Letter: char): string; static;
84 class function uniqueFilename(const filename: string): string; static;
85 class function VtsSpecial(const filename: string): string; static;
86 procedure DeleteAllFiles(mask: string = '');
87 end;
88
89 implementation
90
91 {$R *.dfm}
92
93 uses
94 FileCtrl, DateUtils, inifiles, IdHashMessageDigest, idHash, Math, Clipbrd,
95 StrUtils, AdoConnHelper, MainForm;
96
97 const
98 Win32ImportSuffix = {$IFDEF Unicode}'W'{$ELSE}'A'{$ENDIF};
99
100 function GetVolumeNameForVolumeMountPointA(lpszVolumeMountPoint: PAnsiChar;
101 lpszVolumeName: PAnsiChar; cchBufferLength: DWORD): BOOL; stdcall;
102 external 'kernel32.dll';
103 function GetVolumeNameForVolumeMountPointW(lpszVolumeMountPoint: PWideChar;
104 lpszVolumeName: PWideChar; cchBufferLength: DWORD): BOOL; stdcall;
105 external 'kernel32.dll';
106 function GetVolumeNameForVolumeMountPoint(lpszVolumeMountPoint: PChar;
107 lpszVolumeName: PChar; cchBufferLength: DWORD): BOOL; stdcall;
108 external 'kernel32.dll' name 'GetVolumeNameForVolumeMountPoint' +
109 Win32ImportSuffix;
110
111 const
112 ERROR_FIELD_SIZE = 200;
113 {$IFDEF VIATHINKSOFT}
114 GUID_EHDD_A = '\\?\Volume{31e044b1-28dc-11e6-9bae-d067e54bf736}\';
115 GUID_EHDD_B = '\\?\Volume{560e8251-2b6a-4ab7-82fc-d03df4d93538}\';
116 {$ENDIF}
117
118 function MD5File(const filename: string): string;
119 var
120 IdMD5: TIdHashMessageDigest5;
121 FS: TFileStream;
122 begin
123 IdMD5 := TIdHashMessageDigest5.Create;
124 FS := TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite);
125 try
126 {$IFDEF UNICODE} // I actually do not know at which version of Delphi/Indy, this has changed.
127 Result := IdMD5.HashStreamAsHex(FS);
128 {$ELSE}
129 Result := IdMD5.AsHex(IdMD5.HashValue(FS));
130 {$ENDIF}
131 finally
132 FS.Free;
133 IdMD5.Free;
134 end;
135 end;
136
137 function FileMTime_UTC(const filename: string): TDateTime;
138 var
139 fad: TWin32FileAttributeData;
140 systime: SYSTEMTIME;
141 begin
142 if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then
143 RaiseLastOSError;
144
145 FileTimeToSystemTime(fad.ftLastWriteTime, systime);
146
147 Result := SystemTimeToDateTime(systime);
148 end;
149
150 function FileCTime_UTC(const filename: string): TDateTime;
151 var
152 fad: TWin32FileAttributeData;
153 systime: SYSTEMTIME;
154 begin
155 if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then
156 RaiseLastOSError;
157
158 FileTimeToSystemTime(fad.ftCreationTime, systime);
159
160 Result := SystemTimeToDateTime(systime);
161 end;
162
163 function GetFileSize(const AFileName: String): int64;
164 var
165 lFindData: TWin32FindData;
166 lHandle: Cardinal;
167 begin
168 // https://www.delphipraxis.net/24331-dateigroesse-einer-beliebigen-datei-ermitteln.html
169 lHandle := FindFirstFile(PChar(AFileName), lFindData);
170 if (lHandle <> INVALID_HANDLE_VALUE) then
171 begin
172 Result := lFindData.nFileSizeLow;
173 PCardinal(Cardinal(@Result) + SizeOf(Cardinal))^ := lFindData.nFileSizeHigh;
174 Windows.FindClose(lHandle);
175 end
176 else
177 Result := 0;
178 end;
179
180 function IntToStr2(i: int64): string;
181 begin
182 // https://www.delphipraxis.net/150464-integer-mit-tausender-trennzeichen-ausgeben.html
183 Result := Format('%.0n', [i / 1]);
184 end;
185
186 function ConvertBytes(Bytes: int64): string;
187 const
188 Description: Array [0 .. 8] of string = ('Bytes', 'KB', 'MB', 'GB', 'TB',
189 'PB', 'EB', 'ZB', 'YB');
190 var
191 i: Integer;
192 begin
193 // https://stackoverflow.com/questions/30548940/correct-way-to-convert-size-in-bytes-to-kb-mb-gb-delphi
194 i := 0;
195
196 while Bytes > Power(1024, i + 1) do
197 Inc(i);
198
199 Result := FormatFloat('###0.##', Bytes / IntPower(1024, i)) + ' ' +
200 Description[i];
201 end;
202
203 var
204 DriveGuidCache: TStringList = nil;
205
206 class function TfrmIndexCreator.DriveGuid(const Letter: char): string;
207 var
208 Buffer: array [0 .. 49] of char;
209 begin
210 if not Assigned(DriveGuidCache) then
211 DriveGuidCache := TStringList.Create;
212
213 Result := DriveGuidCache.Values[Letter];
214 if Result = '' then
215 begin
216 Win32Check(GetVolumeNameForVolumeMountPoint(PChar(Letter + ':\'), Buffer,
217 Length(Buffer)));
218 Result := Buffer;
219 DriveGuidCache.Values[Letter] := Result;
220 end;
221 end;
222
223 class function TfrmIndexCreator.uniqueFilename(const filename: string): string;
224 var
225 guid: string;
226 begin
227 if Length(filename) < 2 then
228 exit;
229 if filename[2] = ':' then
230 begin
231 guid := DriveGuid(filename[1]);
232
233 Result := guid + Copy(filename, 4, Length(filename) - 3);
234
235 // result := LowerCase(result);
236 end
237 else
238 Result := filename; // z.B. UNC-Pfad
239 end;
240
241 class function TfrmIndexCreator.VtsSpecial(const filename: string): string;
242 begin
243 Result := filename;
244 {$IFDEF VIATHINKSOFT}
245 Result := StringReplace(Result, GUID_EHDD_A, 'EHDD:\', []);
246 Result := StringReplace(Result, GUID_EHDD_B, 'EHDD:\', []);
247 {$ENDIF}
248 end;
249
250 function SpecialCompare(a, b: TDateTime): boolean; // true = same timestamp
251 begin
252 if SecondsBetween(a,b) < 2 then exit(true); // equal
253
254 if SecondsBetween(a,b) > 7200 then exit(false);
255
256 // Minute and Second equal, and difference is < 2h: fair enough, seems to be a DST issue
257 if copy(TimeToStr(a),4,5) = copy(TimeToStr(b),4,5) then exit(true);
258
259 result := false;
260 end;
261
262 procedure TfrmIndexCreator.CheckFile(const originalFileName,
263 uniqueFilename: string);
264
265 function DateTimeToSQL(dt: TDateTime): string;
266 begin
267 if dt = -1 then
268 Result := 'NULL'
269 else
270 Result := conn.SQLStringEscape(DateTimetoStr(dt));
271 end;
272
273 type
274 TExistResult = (erDoesNotExist, erHadError, erChanged, erUnchanged);
275
276 var
277 lastCheckedMd5: string;
278
279 function Exists(const filename: string; size: int64;
280 const modified: TDateTime): TExistResult;
281 var
282 q: TADODataSet;
283 begin
284 q := conn.GetTable('select error, size, modified, md5hash from ' + TableName
285 + ' where filename = ' + conn.SQLStringEscape
286 (VtsSpecial(uniqueFilename)));
287 try
288 if q.RecordCount = 0 then
289 Result := erDoesNotExist
290 else if not q.Fields[0].IsNull then
291 Result := erHadError
292 else if (q.Fields[1].AsString <> IntToStr(size)) or // we are combining strings because of int64
293 not SpecialCompare(q.Fields[2].AsDateTime, modified) then
294 begin
295 Result := erChanged
296 end
297 else
298 Result := erUnchanged;
299 lastCheckedMd5 := q.Fields[3].AsString;
300 finally
301 FreeAndNil(q);
302 end;
303 end;
304
305 var
306 created, modified: TDateTime;
307 size: int64;
308 md5: string;
309 begin
310 Label1.Caption := MinimizeName(originalFileName, Label1.Canvas, Label1.Width);
311 Application.ProcessMessages;
312
313 try
314 if FileExists(uniqueFilename) then
315 created := FileCTime_UTC(uniqueFilename)
316 else
317 created := -1;
318
319 if FileExists(uniqueFilename) then
320 modified := FileMTime_UTC(uniqueFilename)
321 else
322 modified := -1;
323
324 size := GetFileSize(uniqueFilename);
325 Inc(sumsize, size);
326 Inc(sumfiles);
327
328 if rgModus.ItemIndex = modusRecreate then
329 begin
330 md5 := MD5File(uniqueFilename);
331 if not cbSimulate.Checked then
332 begin
333 conn.ExecSQL('INSERT INTO ' + TableName +
334 ' (filename, size, created, modified, md5hash, error) values (' +
335 conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
336 IntToStr(size) + ', ' + DateTimeToSQL(created) +
337 ', ' + DateTimeToSQL(modified) + ', ' +
338 conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
339 end;
340 if cbVerboseLogs.Checked then
341 Memo2.Lines.Add('New: ' + uniqueFilename);
342 Inc(sumfiles_new);
343 end
344 else
345 begin
346 case Exists(uniqueFilename, size, modified) of
347 erDoesNotExist: // File does not exist or has a different hash
348 begin
349 if rgModus.ItemIndex <> modusValidation then
350 md5 := MD5File(uniqueFilename);
351 if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
352 then
353 begin
354 conn.ExecSQL('INSERT INTO ' + TableName +
355 ' (filename, size, created, modified, md5hash, error) values ('
356 + conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
357 IntToStr(size) + ', ' +
358 DateTimeToSQL(created) + ', ' +
359 DateTimeToSQL(modified) + ', ' +
360 conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
361 end;
362 if cbVerboseLogs.Checked then
363 Memo2.Lines.Add('New: ' + uniqueFilename);
364 Inc(sumfiles_new);
365 end;
366 erHadError, erChanged:
367 begin
368 if rgModus.ItemIndex <> modusValidation then
369 md5 := MD5File(uniqueFilename);
370 if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
371 then
372 begin
373 conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
374 IntToStr(size) + ', created = ' +
375 DateTimeToSQL(created) + ', modified = ' +
376 DateTimeToSQL(modified) + ', md5hash = ' +
377 conn.SQLStringEscape(LowerCase(md5)) +
378 ', error = NULL WHERE filename = ' + conn.SQLStringEscape
379 (VtsSpecial(uniqueFilename)) + ';');
380 end;
381 if cbVerboseLogs.Checked then
382 Memo2.Lines.Add('Updated: ' + uniqueFilename);
383 Inc(sumfiles_updated);
384 end;
385 erUnchanged: // Date/Time+Size has not changed
386 begin
387 {$REGION 'Update it to correct wrong UTC/DST datasets...'}
388 conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
389 IntToStr(size) + ', created = ' +
390 DateTimeToSQL(created) + ', modified = ' +
391 DateTimeToSQL(modified) +
392 ', error = NULL WHERE filename = ' + conn.SQLStringEscape
393 (VtsSpecial(uniqueFilename)) + ';');
394 {$ENDREGION}
395
396 if rgModus.ItemIndex = modusValidation then
397 begin
398 md5 := MD5File(uniqueFilename);
399 if not SameText(md5, lastCheckedMd5) then
400 begin
401 Memo2.Lines.Add
402 ('!!! HASH HAS CHANGED WHILE DATETIME+SIZE IS THE SAME: ' +
403 uniqueFilename + ' (' + lastCheckedMd5 + ' became ' +
404 md5 + ')');
405 Memo2.Color := clRed;
406 Inc(sumfiles_integrityfail);
407 end;
408 end;
409 end;
410 end;
411 end;
412 except
413 on E: Exception do
414 begin
415 if E is EAbort then
416 Abort;
417 // if AdoConnection1.InTransaction then AdoConnection1.RollbackTrans;
418 // AdoConnection1.BeginTrans;
419 try
420 if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
421 then
422 begin
423 conn.ExecSQL('DELETE FROM ' + TableName + ' WHERE filename = ' +
424 conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ';');
425 conn.ExecSQL('INSERT INTO ' + TableName +
426 ' (filename, size, created, modified, md5hash, error) values (' +
427 conn.SQLStringEscape(VtsSpecial(uniqueFilename)) +
428 ', NULL, NULL, NULL, NULL, ' + conn.SQLStringEscape(Copy(E.Message,
429 1, ERROR_FIELD_SIZE)) + ');');
430 Memo2.Lines.Add('Error (logged): ' + E.Message + ' at file ' +
431 VtsSpecial(uniqueFilename));
432 end
433 else
434 begin
435 Memo2.Lines.Add('Error: ' + E.Message + ' at file ' +
436 VtsSpecial(uniqueFilename));
437 end;
438 // AdoConnection1.CommitTrans;
439 except
440 // AdoConnection1.RollbackTrans;
441 Memo2.Lines.Add('Cannot write error into file database! ' + E.Message +
442 ' at file ' + VtsSpecial(uniqueFilename));
443 end;
444 Inc(sumfiles_error);
445 end;
446 end;
447
448 RedrawStats;
449 Application.ProcessMessages;
450 end;
451
452 function TfrmIndexCreator.conn: TAdoConnection;
453 begin
454 Result := frmMain.AdoConnection1;
455 end;
456
457 procedure TfrmIndexCreator.RedrawStats;
458 begin
459 Label5.Caption := ConvertBytes(sumsize);
460 Label6.Caption := IntToStr2(sumfiles);
461 Label7.Caption := IntToStr2(sumfiles_new);
462 Label9.Caption := IntToStr2(sumfiles_updated);
463 Label11.Caption := IntToStr2(sumfiles_error);
464 Label12.Caption := IntToStr2(sumfiles_deleted);
465 // LabelXX.Caption := IntToStr2(sumfiles_integrityfail);
466 end;
467
468 procedure TfrmIndexCreator.Copyuniquepathtoclipboard1Click(Sender: TObject);
469 var
470 s: string;
471 begin
472 s := uniqueFilename(LabeledEdit2.Text);
473 Clipboard.AsText := s;
474 {$IFDEF VIATHINKSOFT}
475 if VtsSpecial(s) <> s then
476 begin
477 s := s + #13#10 + VtsSpecial(s);
478 end;
479 {$ENDIF}
480 ShowMessageFmt('Copied to clipboard:' + #13#10#13#10 + '%s', [s]);
481 end;
482
483 procedure TfrmIndexCreator.rgModusClick(Sender: TObject);
484 begin
485 cbSimulate.enabled := rgModus.ItemIndex <> modusValidation;
486 cbNoDelete.enabled := rgModus.ItemIndex <> modusValidation;
487 end;
488
489 function TfrmIndexCreator.TableName: string;
490 begin
491 Result := frmMain.TableName;
492 end;
493
494 procedure TfrmIndexCreator.Rec(StartDir: string; const FileMask: string);
495 var
496 SR: TSearchRec;
497 DirList: TStrings;
498 IsFound: boolean;
499 i: Integer;
500 UniqueStartDir: string;
501 begin
502 StartDir := IncludeTrailingPathDelimiter(StartDir);
503
504 i := 0;
505 conn.BeginTrans;
506 IsFound := FindFirst(StartDir + FileMask, faAnyFile - faDirectory, SR) = 0;
507 try
508 while IsFound do
509 begin
510 Inc(i);
511 if i mod 1000 = 0 then // Only for performance
512 begin
513 conn.CommitTrans;
514 conn.BeginTrans;
515 end;
516 Application.ProcessMessages;
517 if Application.Terminated or StopRequest then
518 Abort;
519
520 if UniqueStartDir = '' then
521 UniqueStartDir := uniqueFilename(StartDir);
522 CheckFile(StartDir + SR.Name, UniqueStartDir + SR.Name);
523 IsFound := FindNext(SR) = 0;
524 end;
525 finally
526 FindClose(SR);
527 conn.CommitTrans;
528 end;
529
530 // Build a list of subdirectories
531 DirList := TStringList.Create;
532 try
533 IsFound := FindFirst(StartDir + '*', faDirectory, SR) = 0;
534 try
535 while IsFound do
536 begin
537 if (SR.Name <> '.') and (SR.Name <> '..') then
538 begin
539 Application.ProcessMessages;
540 if Application.Terminated or StopRequest then
541 Abort;
542
543 DirList.Add(StartDir + SR.Name);
544 end;
545 IsFound := FindNext(SR) = 0;
546 end;
547 finally
548 FindClose(SR);
549 end;
550
551 // Scan the list of subdirectories
552 for i := 0 to DirList.Count - 1 do
553 begin
554 try
555 Rec(DirList[i], FileMask);
556 except
557 on E: Exception do
558 begin
559 if E is EAbort then
560 Abort;
561 Memo2.Lines.Add('Unexpected error at directory ' + DirList[i] + ': ' +
562 E.Message);
563 end;
564 end;
565 end;
566 finally
567 DirList.Free;
568 end;
569 end;
570
571 procedure TfrmIndexCreator.DeleteAllFiles(mask: string = '');
572 begin
573 sumfiles_deleted := conn.GetScalar('select count(*) as cnt from ' + TableName
574 + ' where filename like ' + conn.SQLStringEscape(VtsSpecial(mask)));
575 RedrawStats;
576
577 if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation) then
578 begin
579 if (mask = '') or (mask = '%') then
580 conn.ExecSQL('delete from ' + TableName)
581 else
582 conn.ExecSQL('delete from ' + TableName + ' where filename like ' +
583 conn.SQLStringEscape(VtsSpecial(mask)));
584 end;
585 end;
586
587 procedure TfrmIndexCreator.DeleteVanishedFiles(mask: string = '');
588
589 {$IFDEF VIATHINKSOFT}
590 var
591 cacheAconnected: boolean;
592 cacheBconnected: boolean;
593 {$ENDIF}
594 function AllowFileCheck(AFileName: string): boolean;
595 var
596 guid: string;
597 begin
598 Result := false;
599 {$IFDEF VIATHINKSOFT}
600 if StartsText('EHDD:\', AFileName) then
601 begin
602 if not cacheAconnected and SysUtils.DirectoryExists(GUID_EHDD_A) then
603 begin
604 cacheAconnected := true;
605 end;
606 if not cacheBconnected and SysUtils.DirectoryExists(GUID_EHDD_B) then
607 begin
608 cacheBconnected := true;
609 end;
610 Result := cacheAconnected or cacheBconnected;
611 end
612 else
613 {$ENDIF}
614 if StartsText('\\?\Volume', AFileName) then
615 begin
616 guid := Copy(AFileName, 1, 49);
617 if EndsText('\', guid) then // should always happen
618 begin
619 // TODO: cache this result somehow, so that DirectoryExists() does not need to be called all the time
620 if SysUtils.DirectoryExists(guid) then // is drive connected/existing?
621 begin
622 Result := true;
623 end;
624 end;
625 end
626 else
627 begin
628 // TODO: Einen Code für Netzlaufwerke machen: Wir dürfen nur Dateien löschen,
629 // wenn das Netzlaufwerk wirklich da ist.
630 end;
631 end;
632
633 function FileDoesExist(AFileName: string): boolean;
634 begin
635 {$IFDEF VIATHINKSOFT}
636 if StartsText('EHDD:\', AFileName) then
637 begin
638 // Attention: AllowFileCheck must be called to initialize cacheAconnected and cacheBconnected
639
640 if cacheAconnected and FileExists(StringReplace(AFileName, 'EHDD:\',
641 GUID_EHDD_A, [])) then
642 exit(true);
643
644 if cacheBconnected and FileExists(StringReplace(AFileName, 'EHDD:\',
645 GUID_EHDD_B, [])) then
646 exit(true);
647
648 exit(false);
649 end;
650 {$ENDIF}
651 exit(FileExists(AFileName));
652 end;
653
654 var
655 filename: string;
656 q: TADODataSet;
657 fFileName: TField;
658 i: int64;
659 begin
660 if mask <> '' then
661 q := conn.GetTable('select filename from ' + TableName +
662 ' where filename like ' + conn.SQLStringEscape(VtsSpecial(mask)))
663 else
664 q := conn.GetTable('select filename from ' + TableName);
665 try
666 i := 0;
667 fFileName := q.FieldByName('filename');
668 while not q.Eof do
669 begin
670 filename := fFileName.AsString;
671
672 if AllowFileCheck(filename) and not FileDoesExist(filename) then
673 begin
674 if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
675 then
676 begin
677 conn.ExecSQL('delete from ' + TableName + ' where filename = ' +
678 conn.SQLStringEscape(filename));
679 end;
680 Inc(sumfiles_deleted);
681 if cbVerboseLogs.Checked then
682 Memo2.Lines.Add('Deleted: ' + filename);
683 RedrawStats;
684 end;
685
686 Inc(i);
687 if i mod 100 = 0 then
688 begin
689 Label1.Caption := MinimizeName(filename, Label1.Canvas, Label1.Width);
690 Application.ProcessMessages;
691 if Application.Terminated or StopRequest then
692 Abort;
693 end;
694
695 q.Next;
696 end;
697 finally
698 FreeAndNil(q);
699 end;
700 end;
701
702 procedure TfrmIndexCreator.IndexDrive(initialdir: string);
703 begin
704 if not cbNoDelete.Checked and not cbSimulate.Checked and
705 (rgModus.ItemIndex <> modusValidation) then
706 begin
707 if rgModus.ItemIndex = modusRecreate then
708 begin
709 DeleteAllFiles(uniqueFilename(IncludeTrailingPathDelimiter
710 (initialdir)) + '%');
711 end
712 else
713 begin
714 DeleteVanishedFiles
715 (uniqueFilename(IncludeTrailingPathDelimiter(initialdir)) + '%');
716 end;
717 end;
718
719 Rec(IncludeTrailingPathDelimiter(initialdir), '*');
720 end;
721
722 procedure TfrmIndexCreator.Button1Click(Sender: TObject);
723 begin
724 sumsize := 0;
725 sumfiles := 0;
726 sumfiles_new := 0;
727 sumfiles_updated := 0;
728 sumfiles_error := 0;
729 sumfiles_deleted := 0;
730 sumfiles_integrityfail := 0;
731
732 Label1.Caption := 'Please wait...';
733 Label5.Caption := '0';
734 Label6.Caption := '0';
735 Label7.Caption := '0';
736 Label9.Caption := '0';
737 Label11.Caption := '0';
738 Label12.Caption := '0';
739 Application.ProcessMessages;
740
741 EnableDisableControls(false);
742 try
743 if not SysUtils.DirectoryExists(LabeledEdit2.Text) then
744 begin
745 raise Exception.CreateFmt('Directory %s not found.', [LabeledEdit2.Text]);
746 end;
747
748 IndexDrive(LabeledEdit2.Text);
749
750 (*
751 if not Application.Terminated or StopRequest then
752 begin
753 ShowMessage('Finished');
754 end;
755 *)
756 finally
757 if not StopRequest then EnableDisableControls(true);
758 end;
759
760 if not StopRequest then
761 begin
762 Beep;
763 Label1.Caption := 'Done.';
764 Application.ProcessMessages;
765 end;
766 end;
767
768 procedure TfrmIndexCreator.FormClose(Sender: TObject; var Action: TCloseAction);
769 begin
770 StopRequest := true;
771 Action := caFree; // TODO: müssen wir warten bis der prozess angehalten ist?
772 end;
773
774 procedure TfrmIndexCreator.FormShow(Sender: TObject);
775 var
776 ini: TMemIniFile;
777 begin
778 ini := frmMain.ini;
779 rgModus.ItemIndex := ini.ReadInteger('IndexCreator', 'DefaultMode', modusUpdate);
780 cbNoDelete.Checked := ini.ReadBool('IndexCreator', 'DefaultCheckVanished', false);
781 cbVerboseLogs.Checked := ini.ReadBool('IndexCreator', 'DefaultVerboseLogs', false);
782 cbSimulate.Checked := ini.ReadBool('IndexCreator', 'DefaultSimulate', false);
783 LabeledEdit2.Text := ini.ReadString('IndexCreator', 'DefaultDir', 'C:\');
784 end;
785
786 procedure TfrmIndexCreator.Button2Click(Sender: TObject);
787 begin
788 StopRequest := true;
789 Close;
790 end;
791
792 procedure TfrmIndexCreator.Button4Click(Sender: TObject);
793 var
794 i: Integer;
795 s: string;
796 begin
797 sumsize := 0;
798 sumfiles := 0;
799 sumfiles_new := 0;
800 sumfiles_updated := 0;
801 sumfiles_error := 0;
802 sumfiles_deleted := 0;
803
804 Label1.Caption := 'Please wait...';
805 Label5.Caption := '0';
806 Label6.Caption := '0';
807 Label7.Caption := '0';
808 Label9.Caption := '0';
809 Label11.Caption := '0';
810 Label12.Caption := '0';
811 Application.ProcessMessages;
812
813 EnableDisableControls(false);
814 try
815 // if fileexists('tmp') then memo1.lines.LoadFromFile('tmp');
816 for i := Memo1.Lines.Count - 1 downto 0 do
817 begin
818 s := Memo1.Lines.strings[i];
819 if Trim(s) <> '' then
820 begin
821 LabeledEdit2.Text := s;
822
823 if not SysUtils.DirectoryExists(LabeledEdit2.Text) then
824 begin
825 raise Exception.CreateFmt('Directory %s not found.',
826 [LabeledEdit2.Text]);
827 end;
828
829 IndexDrive(LabeledEdit2.Text);
830 end;
831 Memo1.Lines.Delete(i);
832 // memo1.lines.SaveToFile('tmp');
833 end;
834
835 (*
836 if not Application.Terminated or StopRequest then
837 begin
838 ShowMessage('Finished');
839 end;
840 *)
841 finally
842 EnableDisableControls(true);
843 end;
844
845 Beep;
846 Label1.Caption := 'Done.';
847 Application.ProcessMessages;
848 end;
849
850 procedure TfrmIndexCreator.EnableDisableControls(enabled: boolean);
851 begin
852 rgModus.enabled := enabled;
853 cbNoDelete.enabled := enabled and (rgModus.ItemIndex <> modusValidation);
854 cbVerboseLogs.enabled := enabled;
855 cbSimulate.enabled := enabled and (rgModus.ItemIndex <> modusValidation);
856 Button1.enabled := enabled;
857 LabeledEdit2.enabled := enabled;
858 Memo1.enabled := enabled;
859 Button4.enabled := enabled;
860 end;
861
862 end.