Login | ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/indexer_suite/trunk/IndexCreatorForm.pas
Revision: 9
Committed: Sun Jun 13 22:50:47 2021 UTC (11 months ago) by daniel-marschall
Content type: text/x-pascal
File size: 26755 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 // Example of multiple drives merging to one Index
115 // Find out via "mountvol" command
116 GUID_EHDD_A = '\\?\Volume{31e044b1-28dc-11e6-9bae-d067e54bf736}\';
117 GUID_EHDD_B = '\\?\Volume{560e8251-2b6a-4ab7-82fc-d03df4d93538}\';
118 GUID_EHDD_R = '\\?\Volume{9d53ea3c-175c-4a8f-a7b4-7b9e6b765e58}\';
119 {$ENDIF}
120
121 function MD5File(const filename: string): string;
122 var
123 IdMD5: TIdHashMessageDigest5;
124 FS: TFileStream;
125 begin
126 IdMD5 := TIdHashMessageDigest5.Create;
127 FS := TFileStream.Create(filename, fmOpenRead or fmShareDenyWrite);
128 try
129 {$IFDEF UNICODE} // I actually do not know at which version of Delphi/Indy, this has changed.
130 Result := IdMD5.HashStreamAsHex(FS);
131 {$ELSE}
132 Result := IdMD5.AsHex(IdMD5.HashValue(FS));
133 {$ENDIF}
134 finally
135 FS.Free;
136 IdMD5.Free;
137 end;
138 end;
139
140 function FileMTime_UTC(const filename: string): TDateTime;
141 var
142 fad: TWin32FileAttributeData;
143 systime: SYSTEMTIME;
144 begin
145 if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then
146 RaiseLastOSError;
147
148 FileTimeToSystemTime(fad.ftLastWriteTime, systime);
149
150 Result := SystemTimeToDateTime(systime);
151 end;
152
153 function FileCTime_UTC(const filename: string): TDateTime;
154 var
155 fad: TWin32FileAttributeData;
156 systime: SYSTEMTIME;
157 begin
158 if not GetFileAttributesEx(PChar(filename), GetFileExInfoStandard, @fad) then
159 RaiseLastOSError;
160
161 FileTimeToSystemTime(fad.ftCreationTime, systime);
162
163 Result := SystemTimeToDateTime(systime);
164 end;
165
166 function GetFileSize(const AFileName: String): int64;
167 var
168 lFindData: TWin32FindData;
169 lHandle: Cardinal;
170 begin
171 // https://www.delphipraxis.net/24331-dateigroesse-einer-beliebigen-datei-ermitteln.html
172 lHandle := FindFirstFile(PChar(AFileName), lFindData);
173 if (lHandle <> INVALID_HANDLE_VALUE) then
174 begin
175 Result := lFindData.nFileSizeLow;
176 PCardinal(Cardinal(@Result) + SizeOf(Cardinal))^ := lFindData.nFileSizeHigh;
177 Windows.FindClose(lHandle);
178 end
179 else
180 Result := 0;
181 end;
182
183 function IntToStr2(i: int64): string;
184 begin
185 // https://www.delphipraxis.net/150464-integer-mit-tausender-trennzeichen-ausgeben.html
186 Result := Format('%.0n', [i / 1]);
187 end;
188
189 function ConvertBytes(Bytes: int64): string;
190 const
191 Description: Array [0 .. 8] of string = ('Bytes', 'KB', 'MB', 'GB', 'TB',
192 'PB', 'EB', 'ZB', 'YB');
193 var
194 i: Integer;
195 begin
196 // https://stackoverflow.com/questions/30548940/correct-way-to-convert-size-in-bytes-to-kb-mb-gb-delphi
197 i := 0;
198
199 while Bytes > Power(1024, i + 1) do
200 Inc(i);
201
202 Result := FormatFloat('###0.##', Bytes / IntPower(1024, i)) + ' ' +
203 Description[i];
204 end;
205
206 var
207 DriveGuidCache: TStringList = nil;
208
209 class function TfrmIndexCreator.DriveGuid(const Letter: char): string;
210 var
211 Buffer: array [0 .. 49] of char;
212 begin
213 if not Assigned(DriveGuidCache) then
214 DriveGuidCache := TStringList.Create;
215
216 Result := DriveGuidCache.Values[Letter];
217 if Result = '' then
218 begin
219 Win32Check(GetVolumeNameForVolumeMountPoint(PChar(Letter + ':\'), Buffer,
220 Length(Buffer)));
221 Result := Buffer;
222 DriveGuidCache.Values[Letter] := Result;
223 end;
224 end;
225
226 class function TfrmIndexCreator.uniqueFilename(const filename: string): string;
227 var
228 guid: string;
229 begin
230 if Length(filename) < 2 then
231 exit;
232 if filename[2] = ':' then
233 begin
234 guid := DriveGuid(filename[1]);
235
236 Result := guid + Copy(filename, 4, Length(filename) - 3);
237
238 // result := LowerCase(result);
239 end
240 else
241 Result := filename; // z.B. UNC-Pfad
242 end;
243
244 class function TfrmIndexCreator.VtsSpecial(const filename: string): string;
245 begin
246 Result := filename;
247 {$IFDEF VIATHINKSOFT}
248 Result := StringReplace(Result, GUID_EHDD_A, 'EHDD:\', []);
249 Result := StringReplace(Result, GUID_EHDD_B, 'EHDD:\', []);
250 Result := StringReplace(Result, GUID_EHDD_R, 'EHDD:\', []);
251 {$ENDIF}
252 end;
253
254 function SpecialCompare(a, b: TDateTime): boolean; // true = same timestamp
255 begin
256 if SecondsBetween(a,b) < 2 then exit(true); // equal
257
258 if SecondsBetween(a,b) > 7200 then exit(false);
259
260 // Minute and Second equal, and difference is < 2h: fair enough, seems to be a DST issue
261 if copy(TimeToStr(a),4,5) = copy(TimeToStr(b),4,5) then exit(true);
262
263 result := false;
264 end;
265
266 procedure TfrmIndexCreator.CheckFile(const originalFileName,
267 uniqueFilename: string);
268
269 function DateTimeToSQL(dt: TDateTime): string;
270 begin
271 if dt = -1 then
272 Result := 'NULL'
273 else
274 Result := conn.SQLStringEscape(DateTimetoStr(dt));
275 end;
276
277 type
278 TExistResult = (erDoesNotExist, erHadError, erChanged, erUnchanged);
279
280 var
281 lastCheckedMd5: string;
282
283 function Exists(const filename: string; size: int64;
284 const modified: TDateTime): TExistResult;
285 var
286 q: TADODataSet;
287 begin
288 q := conn.GetTable('select error, size, modified, md5hash from ' + TableName
289 + ' where filename = ' + conn.SQLStringEscape
290 (VtsSpecial(uniqueFilename)));
291 try
292 if q.RecordCount = 0 then
293 Result := erDoesNotExist
294 else if not q.Fields[0].IsNull then
295 Result := erHadError
296 else if (q.Fields[1].AsString <> IntToStr(size)) or // we are combining strings because of int64
297 not SpecialCompare(q.Fields[2].AsDateTime, modified) then
298 begin
299 Result := erChanged
300 end
301 else
302 Result := erUnchanged;
303 lastCheckedMd5 := q.Fields[3].AsString;
304 finally
305 FreeAndNil(q);
306 end;
307 end;
308
309 var
310 created, modified: TDateTime;
311 size: int64;
312 md5: string;
313 begin
314 Label1.Caption := MinimizeName(originalFileName, Label1.Canvas, Label1.Width);
315 Application.ProcessMessages;
316
317 try
318 if FileExists(uniqueFilename) then
319 created := FileCTime_UTC(uniqueFilename)
320 else
321 created := -1;
322
323 if FileExists(uniqueFilename) then
324 modified := FileMTime_UTC(uniqueFilename)
325 else
326 modified := -1;
327
328 size := GetFileSize(uniqueFilename);
329 Inc(sumsize, size);
330 Inc(sumfiles);
331
332 if rgModus.ItemIndex = modusRecreate then
333 begin
334 md5 := MD5File(uniqueFilename);
335 if not cbSimulate.Checked then
336 begin
337 conn.ExecSQL('INSERT INTO ' + TableName +
338 ' (filename, size, created, modified, md5hash, error) values (' +
339 conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
340 IntToStr(size) + ', ' + DateTimeToSQL(created) +
341 ', ' + DateTimeToSQL(modified) + ', ' +
342 conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
343 end;
344 if cbVerboseLogs.Checked then
345 Memo2.Lines.Add('New: ' + uniqueFilename);
346 Inc(sumfiles_new);
347 end
348 else
349 begin
350 case Exists(uniqueFilename, size, modified) of
351 erDoesNotExist: // File does not exist or has a different hash
352 begin
353 if rgModus.ItemIndex <> modusValidation then
354 md5 := MD5File(uniqueFilename);
355 if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
356 then
357 begin
358 conn.ExecSQL('INSERT INTO ' + TableName +
359 ' (filename, size, created, modified, md5hash, error) values ('
360 + conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
361 IntToStr(size) + ', ' +
362 DateTimeToSQL(created) + ', ' +
363 DateTimeToSQL(modified) + ', ' +
364 conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
365 end;
366 if cbVerboseLogs.Checked then
367 Memo2.Lines.Add('New: ' + uniqueFilename);
368 Inc(sumfiles_new);
369 end;
370 erHadError, erChanged:
371 begin
372 if rgModus.ItemIndex <> modusValidation then
373 md5 := MD5File(uniqueFilename);
374 if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
375 then
376 begin
377 conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
378 IntToStr(size) + ', created = ' +
379 DateTimeToSQL(created) + ', modified = ' +
380 DateTimeToSQL(modified) + ', md5hash = ' +
381 conn.SQLStringEscape(LowerCase(md5)) +
382 ', error = NULL WHERE filename = ' + conn.SQLStringEscape
383 (VtsSpecial(uniqueFilename)) + ';');
384 end;
385 if cbVerboseLogs.Checked then
386 Memo2.Lines.Add('Updated: ' + uniqueFilename);
387 Inc(sumfiles_updated);
388 end;
389 erUnchanged: // Date/Time+Size has not changed
390 begin
391 {$REGION 'Update it to correct wrong UTC/DST datasets...'}
392 conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
393 IntToStr(size) + ', created = ' +
394 DateTimeToSQL(created) + ', modified = ' +
395 DateTimeToSQL(modified) +
396 ', error = NULL WHERE filename = ' + conn.SQLStringEscape
397 (VtsSpecial(uniqueFilename)) + ';');
398 {$ENDREGION}
399
400 if rgModus.ItemIndex = modusValidation then
401 begin
402 md5 := MD5File(uniqueFilename);
403 if not SameText(md5, lastCheckedMd5) then
404 begin
405 Memo2.Lines.Add
406 ('!!! HASH HAS CHANGED WHILE DATETIME+SIZE IS THE SAME: ' +
407 uniqueFilename + ' (' + lastCheckedMd5 + ' became ' +
408 md5 + ')');
409 Memo2.Color := clRed;
410 Inc(sumfiles_integrityfail);
411 end;
412 end;
413 end;
414 end;
415 end;
416 except
417 on E: Exception do
418 begin
419 if E is EAbort then
420 Abort;
421 // if AdoConnection1.InTransaction then AdoConnection1.RollbackTrans;
422 // AdoConnection1.BeginTrans;
423 try
424 if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
425 then
426 begin
427 conn.ExecSQL('DELETE FROM ' + TableName + ' WHERE filename = ' +
428 conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ';');
429 conn.ExecSQL('INSERT INTO ' + TableName +
430 ' (filename, size, created, modified, md5hash, error) values (' +
431 conn.SQLStringEscape(VtsSpecial(uniqueFilename)) +
432 ', NULL, NULL, NULL, NULL, ' + conn.SQLStringEscape(Copy(E.Message,
433 1, ERROR_FIELD_SIZE)) + ');');
434 Memo2.Lines.Add('Error (logged): ' + E.Message + ' at file ' +
435 VtsSpecial(uniqueFilename));
436 end
437 else
438 begin
439 Memo2.Lines.Add('Error: ' + E.Message + ' at file ' +
440 VtsSpecial(uniqueFilename));
441 end;
442 // AdoConnection1.CommitTrans;
443 except
444 // AdoConnection1.RollbackTrans;
445 Memo2.Lines.Add('Cannot write error into file database! ' + E.Message +
446 ' at file ' + VtsSpecial(uniqueFilename));
447 end;
448 Inc(sumfiles_error);
449 end;
450 end;
451
452 RedrawStats;
453 Application.ProcessMessages;
454 end;
455
456 function TfrmIndexCreator.conn: TAdoConnection;
457 begin
458 Result := frmMain.AdoConnection1;
459 end;
460
461 procedure TfrmIndexCreator.RedrawStats;
462 begin
463 Label5.Caption := ConvertBytes(sumsize);
464 Label6.Caption := IntToStr2(sumfiles);
465 Label7.Caption := IntToStr2(sumfiles_new);
466 Label9.Caption := IntToStr2(sumfiles_updated);
467 Label11.Caption := IntToStr2(sumfiles_error);
468 Label12.Caption := IntToStr2(sumfiles_deleted);
469 // LabelXX.Caption := IntToStr2(sumfiles_integrityfail);
470 end;
471
472 procedure TfrmIndexCreator.Copyuniquepathtoclipboard1Click(Sender: TObject);
473 var
474 s: string;
475 begin
476 s := uniqueFilename(LabeledEdit2.Text);
477 Clipboard.AsText := s;
478 {$IFDEF VIATHINKSOFT}
479 if VtsSpecial(s) <> s then
480 begin
481 s := s + #13#10 + VtsSpecial(s);
482 end;
483 {$ENDIF}
484 ShowMessageFmt('Copied to clipboard:' + #13#10#13#10 + '%s', [s]);
485 end;
486
487 procedure TfrmIndexCreator.rgModusClick(Sender: TObject);
488 begin
489 cbSimulate.enabled := rgModus.ItemIndex <> modusValidation;
490 cbNoDelete.enabled := rgModus.ItemIndex <> modusValidation;
491 end;
492
493 function TfrmIndexCreator.TableName: string;
494 begin
495 Result := frmMain.TableName;
496 end;
497
498 procedure TfrmIndexCreator.Rec(StartDir: string; const FileMask: string);
499 var
500 SR: TSearchRec;
501 DirList: TStrings;
502 IsFound: boolean;
503 i: Integer;
504 UniqueStartDir: string;
505 begin
506 StartDir := IncludeTrailingPathDelimiter(StartDir);
507
508 i := 0;
509 conn.BeginTrans;
510 IsFound := FindFirst(StartDir + FileMask, faAnyFile - faDirectory, SR) = 0;
511 try
512 while IsFound do
513 begin
514 Inc(i);
515 if i mod 1000 = 0 then // Only for performance
516 begin
517 conn.CommitTrans;
518 conn.BeginTrans;
519 end;
520 Application.ProcessMessages;
521 if Application.Terminated or StopRequest then
522 Abort;
523
524 if UniqueStartDir = '' then
525 UniqueStartDir := uniqueFilename(StartDir);
526 CheckFile(StartDir + SR.Name, UniqueStartDir + SR.Name);
527 IsFound := FindNext(SR) = 0;
528 end;
529 finally
530 FindClose(SR);
531 conn.CommitTrans;
532 end;
533
534 // Build a list of subdirectories
535 DirList := TStringList.Create;
536 try
537 IsFound := FindFirst(StartDir + '*', faDirectory, SR) = 0;
538 try
539 while IsFound do
540 begin
541 if (SR.Name <> '.') and (SR.Name <> '..') then
542 begin
543 Application.ProcessMessages;
544 if Application.Terminated or StopRequest then
545 Abort;
546
547 DirList.Add(StartDir + SR.Name);
548 end;
549 IsFound := FindNext(SR) = 0;
550 end;
551 finally
552 FindClose(SR);
553 end;
554
555 // Scan the list of subdirectories
556 for i := 0 to DirList.Count - 1 do
557 begin
558 try
559 Rec(DirList[i], FileMask);
560 except
561 on E: Exception do
562 begin
563 if E is EAbort then
564 Abort;
565 Memo2.Lines.Add('Unexpected error at directory ' + DirList[i] + ': ' +
566 E.Message);
567 end;
568 end;
569 end;
570 finally
571 DirList.Free;
572 end;
573 end;
574
575 procedure TfrmIndexCreator.DeleteAllFiles(mask: string = '');
576 begin
577 sumfiles_deleted := conn.GetScalar('select count(*) as cnt from ' + TableName
578 + ' where filename like ' + conn.SQLStringEscape(VtsSpecial(mask)));
579 RedrawStats;
580
581 if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation) then
582 begin
583 if (mask = '') or (mask = '%') then
584 conn.ExecSQL('delete from ' + TableName)
585 else
586 conn.ExecSQL('delete from ' + TableName + ' where filename like ' +
587 conn.SQLStringEscape(VtsSpecial(mask)));
588 end;
589 end;
590
591 procedure TfrmIndexCreator.DeleteVanishedFiles(mask: string = '');
592
593 {$IFDEF VIATHINKSOFT}
594 var
595 cacheAconnected: boolean;
596 cacheBconnected: boolean;
597 cacheRconnected: boolean;
598 {$ENDIF}
599 function AllowFileCheck(AFileName: string): boolean;
600 var
601 guid: string;
602 begin
603 Result := false;
604 {$IFDEF VIATHINKSOFT}
605 if StartsText('EHDD:\', AFileName) then
606 begin
607 if not cacheAconnected and SysUtils.DirectoryExists(GUID_EHDD_A) then
608 begin
609 cacheAconnected := true;
610 end;
611 if not cacheBconnected and SysUtils.DirectoryExists(GUID_EHDD_B) then
612 begin
613 cacheBconnected := true;
614 end;
615 if not cacheRconnected and SysUtils.DirectoryExists(GUID_EHDD_R) then
616 begin
617 cacheRconnected := true;
618 end;
619 Result := cacheAconnected or cacheBconnected or cacheRconnected;
620 end
621 else
622 {$ENDIF}
623 if StartsText('\\?\Volume', AFileName) then
624 begin
625 guid := Copy(AFileName, 1, 49);
626 if EndsText('\', guid) then // should always happen
627 begin
628 // TODO: cache this result somehow, so that DirectoryExists() does not need to be called all the time
629 if SysUtils.DirectoryExists(guid) then // is drive connected/existing?
630 begin
631 Result := true;
632 end;
633 end;
634 end
635 else
636 begin
637 // TODO: Einen Code für Netzlaufwerke machen: Wir dürfen nur Dateien löschen,
638 // wenn das Netzlaufwerk wirklich da ist.
639 end;
640 end;
641
642 function FileDoesExist(AFileName: string): boolean;
643 begin
644 {$IFDEF VIATHINKSOFT}
645 if StartsText('EHDD:\', AFileName) then
646 begin
647 // Attention: AllowFileCheck must be called to initialize cacheAconnected and cacheBconnected and cacheRconnected
648
649 if cacheAconnected and FileExists(StringReplace(AFileName, 'EHDD:\',
650 GUID_EHDD_A, [])) then
651 exit(true);
652
653 if cacheBconnected and FileExists(StringReplace(AFileName, 'EHDD:\',
654 GUID_EHDD_B, [])) then
655 exit(true);
656
657 if cacheRconnected and FileExists(StringReplace(AFileName, 'EHDD:\',
658 GUID_EHDD_R, [])) then
659 exit(true);
660
661 exit(false);
662 end;
663 {$ENDIF}
664 exit(FileExists(AFileName));
665 end;
666
667 var
668 filename: string;
669 q: TADODataSet;
670 fFileName: TField;
671 i: int64;
672 begin
673 if mask <> '' then
674 q := conn.GetTable('select filename from ' + TableName +
675 ' where filename like ' + conn.SQLStringEscape(VtsSpecial(mask)))
676 else
677 q := conn.GetTable('select filename from ' + TableName);
678 try
679 i := 0;
680 fFileName := q.FieldByName('filename');
681 while not q.Eof do
682 begin
683 filename := fFileName.AsString;
684
685 if AllowFileCheck(filename) and not FileDoesExist(filename) then
686 begin
687 if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
688 then
689 begin
690 conn.ExecSQL('delete from ' + TableName + ' where filename = ' +
691 conn.SQLStringEscape(filename));
692 end;
693 Inc(sumfiles_deleted);
694 if cbVerboseLogs.Checked then
695 Memo2.Lines.Add('Deleted: ' + filename);
696 RedrawStats;
697 end;
698
699 Inc(i);
700 if i mod 100 = 0 then
701 begin
702 Label1.Caption := MinimizeName(filename, Label1.Canvas, Label1.Width);
703 Application.ProcessMessages;
704 if Application.Terminated or StopRequest then
705 Abort;
706 end;
707
708 q.Next;
709 end;
710 finally
711 FreeAndNil(q);
712 end;
713 end;
714
715 procedure TfrmIndexCreator.IndexDrive(initialdir: string);
716 begin
717 if not cbNoDelete.Checked and not cbSimulate.Checked and
718 (rgModus.ItemIndex <> modusValidation) then
719 begin
720 if rgModus.ItemIndex = modusRecreate then
721 begin
722 DeleteAllFiles(uniqueFilename(IncludeTrailingPathDelimiter
723 (initialdir)) + '%');
724 end
725 else
726 begin
727 DeleteVanishedFiles
728 (uniqueFilename(IncludeTrailingPathDelimiter(initialdir)) + '%');
729 end;
730 end;
731
732 Rec(IncludeTrailingPathDelimiter(initialdir), '*');
733 end;
734
735 procedure TfrmIndexCreator.Button1Click(Sender: TObject);
736 begin
737 sumsize := 0;
738 sumfiles := 0;
739 sumfiles_new := 0;
740 sumfiles_updated := 0;
741 sumfiles_error := 0;
742 sumfiles_deleted := 0;
743 sumfiles_integrityfail := 0;
744
745 Label1.Caption := 'Please wait...';
746 Label5.Caption := '0';
747 Label6.Caption := '0';
748 Label7.Caption := '0';
749 Label9.Caption := '0';
750 Label11.Caption := '0';
751 Label12.Caption := '0';
752 Application.ProcessMessages;
753
754 EnableDisableControls(false);
755 try
756 if not SysUtils.DirectoryExists(LabeledEdit2.Text) then
757 begin
758 raise Exception.CreateFmt('Directory %s not found.', [LabeledEdit2.Text]);
759 end;
760
761 IndexDrive(LabeledEdit2.Text);
762
763 (*
764 if not Application.Terminated or StopRequest then
765 begin
766 ShowMessage('Finished');
767 end;
768 *)
769 finally
770 if not StopRequest then EnableDisableControls(true);
771 end;
772
773 if not StopRequest then
774 begin
775 Beep;
776 Label1.Caption := 'Done.';
777 Application.ProcessMessages;
778 end;
779 end;
780
781 procedure TfrmIndexCreator.FormClose(Sender: TObject; var Action: TCloseAction);
782 begin
783 StopRequest := true;
784 Action := caFree; // TODO: müssen wir warten bis der prozess angehalten ist?
785 end;
786
787 procedure TfrmIndexCreator.FormShow(Sender: TObject);
788 var
789 ini: TMemIniFile;
790 begin
791 ini := frmMain.ini;
792 rgModus.ItemIndex := ini.ReadInteger('IndexCreator', 'DefaultMode', modusUpdate);
793 cbNoDelete.Checked := ini.ReadBool('IndexCreator', 'DefaultCheckVanished', false);
794 cbVerboseLogs.Checked := ini.ReadBool('IndexCreator', 'DefaultVerboseLogs', false);
795 cbSimulate.Checked := ini.ReadBool('IndexCreator', 'DefaultSimulate', false);
796 LabeledEdit2.Text := ini.ReadString('IndexCreator', 'DefaultDir', 'C:\');
797 end;
798
799 procedure TfrmIndexCreator.Button2Click(Sender: TObject);
800 begin
801 StopRequest := true;
802 Close;
803 end;
804
805 procedure TfrmIndexCreator.Button4Click(Sender: TObject);
806 var
807 i: Integer;
808 s: string;
809 begin
810 sumsize := 0;
811 sumfiles := 0;
812 sumfiles_new := 0;
813 sumfiles_updated := 0;
814 sumfiles_error := 0;
815 sumfiles_deleted := 0;
816
817 Label1.Caption := 'Please wait...';
818 Label5.Caption := '0';
819 Label6.Caption := '0';
820 Label7.Caption := '0';
821 Label9.Caption := '0';
822 Label11.Caption := '0';
823 Label12.Caption := '0';
824 Application.ProcessMessages;
825
826 EnableDisableControls(false);
827 try
828 // if fileexists('tmp') then memo1.lines.LoadFromFile('tmp');
829 for i := Memo1.Lines.Count - 1 downto 0 do
830 begin
831 s := Memo1.Lines.strings[i];
832 if Trim(s) <> '' then
833 begin
834 LabeledEdit2.Text := s;
835
836 if not SysUtils.DirectoryExists(LabeledEdit2.Text) then
837 begin
838 raise Exception.CreateFmt('Directory %s not found.',
839 [LabeledEdit2.Text]);
840 end;
841
842 IndexDrive(LabeledEdit2.Text);
843 end;
844 Memo1.Lines.Delete(i);
845 // memo1.lines.SaveToFile('tmp');
846 end;
847
848 (*
849 if not Application.Terminated or StopRequest then
850 begin
851 ShowMessage('Finished');
852 end;
853 *)
854 finally
855 EnableDisableControls(true);
856 end;
857
858 Beep;
859 Label1.Caption := 'Done.';
860 Application.ProcessMessages;
861 end;
862
863 procedure TfrmIndexCreator.EnableDisableControls(enabled: boolean);
864 begin
865 rgModus.enabled := enabled;
866 cbNoDelete.enabled := enabled and (rgModus.ItemIndex <> modusValidation);
867 cbVerboseLogs.enabled := enabled;
868 cbSimulate.enabled := enabled and (rgModus.ItemIndex <> modusValidation);
869 Button1.enabled := enabled;
870 LabeledEdit2.enabled := enabled;
871 Memo1.enabled := enabled;
872 Button4.enabled := enabled;
873 end;
874
875 end.