Subversion Repositories indexer_suite

Rev

Rev 4 | Go to most recent revision | Details | Last modification | View Log | RSS feed

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