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

# User Rev Content
1 daniel-marschall 2 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 daniel-marschall 4 // TODO: validate modus auch ohne prüfsummencheck. nur gucken ob die dateien existieren
17 daniel-marschall 2
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 daniel-marschall 8 // Example of multiple drives merging to one Index
115     // Find out via "mountvol" command
116 daniel-marschall 2 GUID_EHDD_A = '\\?\Volume{31e044b1-28dc-11e6-9bae-d067e54bf736}\';
117     GUID_EHDD_B = '\\?\Volume{560e8251-2b6a-4ab7-82fc-d03df4d93538}\';
118 daniel-marschall 8 GUID_EHDD_R = '\\?\Volume{9d53ea3c-175c-4a8f-a7b4-7b9e6b765e58}\';
119 daniel-marschall 2 {$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 daniel-marschall 8 Result := StringReplace(Result, GUID_EHDD_R, 'EHDD:\', []);
251 daniel-marschall 2 {$ENDIF}
252     end;
253    
254 daniel-marschall 6 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 daniel-marschall 2 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 daniel-marschall 6 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 daniel-marschall 2 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 daniel-marschall 6 IntToStr(size) + ', ' + DateTimeToSQL(created) +
341     ', ' + DateTimeToSQL(modified) + ', ' +
342 daniel-marschall 2 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 daniel-marschall 6 DateTimeToSQL(created) + ', ' +
363     DateTimeToSQL(modified) + ', ' +
364 daniel-marschall 2 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 daniel-marschall 6 DateTimeToSQL(created) + ', modified = ' +
380     DateTimeToSQL(modified) + ', md5hash = ' +
381 daniel-marschall 2 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 daniel-marschall 6 {$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 daniel-marschall 2 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 daniel-marschall 8 cacheRconnected: boolean;
598 daniel-marschall 2 {$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 daniel-marschall 8 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 daniel-marschall 2 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 daniel-marschall 9 // Attention: AllowFileCheck must be called to initialize cacheAconnected and cacheBconnected and cacheRconnected
648 daniel-marschall 2
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 daniel-marschall 9 if cacheRconnected and FileExists(StringReplace(AFileName, 'EHDD:\',
658 daniel-marschall 8 GUID_EHDD_R, [])) then
659     exit(true);
660    
661 daniel-marschall 2 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 daniel-marschall 6 if not StopRequest then EnableDisableControls(true);
771 daniel-marschall 2 end;
772    
773 daniel-marschall 6 if not StopRequest then
774     begin
775     Beep;
776     Label1.Caption := 'Done.';
777     Application.ProcessMessages;
778     end;
779 daniel-marschall 2 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.