Subversion Repositories indexer_suite

Rev

Rev 2 | Rev 6 | Go to most recent revision | Details | Compare with Previous | 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)
4 daniel-mar 16
// TODO: validate modus auch ohne prüfsummencheck. nur gucken ob die dateien existieren
2 daniel-mar 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 UTCTimeToLocalTime(const aValue: TDateTime): TDateTime;
164
var
165
  lBias: Integer;
166
  lTZI: TTimeZoneInformation;
167
begin
168
  lBias := 0;
169
  case GetTimeZoneInformation(lTZI) of
170
    TIME_ZONE_ID_UNKNOWN:
171
      lBias := lTZI.Bias;
172
    TIME_ZONE_ID_DAYLIGHT:
173
      lBias := lTZI.Bias + lTZI.DaylightBias;
174
    TIME_ZONE_ID_STANDARD:
175
      lBias := lTZI.Bias + lTZI.StandardBias;
176
  end;
177
  // UTC = local time + bias
178
  // bias is in number of minutes, TDateTime is in days
179
  Result := aValue - (lBias / (24 * 60));
180
end;
181
 
182
function GetFileSize(const AFileName: String): int64;
183
var
184
  lFindData: TWin32FindData;
185
  lHandle: Cardinal;
186
begin
187
  // https://www.delphipraxis.net/24331-dateigroesse-einer-beliebigen-datei-ermitteln.html
188
  lHandle := FindFirstFile(PChar(AFileName), lFindData);
189
  if (lHandle <> INVALID_HANDLE_VALUE) then
190
  begin
191
    Result := lFindData.nFileSizeLow;
192
    PCardinal(Cardinal(@Result) + SizeOf(Cardinal))^ := lFindData.nFileSizeHigh;
193
    Windows.FindClose(lHandle);
194
  end
195
  else
196
    Result := 0;
197
end;
198
 
199
function IntToStr2(i: int64): string;
200
begin
201
  // https://www.delphipraxis.net/150464-integer-mit-tausender-trennzeichen-ausgeben.html
202
  Result := Format('%.0n', [i / 1]);
203
end;
204
 
205
function ConvertBytes(Bytes: int64): string;
206
const
207
  Description: Array [0 .. 8] of string = ('Bytes', 'KB', 'MB', 'GB', 'TB',
208
    'PB', 'EB', 'ZB', 'YB');
209
var
210
  i: Integer;
211
begin
212
  // https://stackoverflow.com/questions/30548940/correct-way-to-convert-size-in-bytes-to-kb-mb-gb-delphi
213
  i := 0;
214
 
215
  while Bytes > Power(1024, i + 1) do
216
    Inc(i);
217
 
218
  Result := FormatFloat('###0.##', Bytes / IntPower(1024, i)) + ' ' +
219
    Description[i];
220
end;
221
 
222
var
223
  DriveGuidCache: TStringList = nil;
224
 
225
class function TfrmIndexCreator.DriveGuid(const Letter: char): string;
226
var
227
  Buffer: array [0 .. 49] of char;
228
begin
229
  if not Assigned(DriveGuidCache) then
230
    DriveGuidCache := TStringList.Create;
231
 
232
  Result := DriveGuidCache.Values[Letter];
233
  if Result = '' then
234
  begin
235
    Win32Check(GetVolumeNameForVolumeMountPoint(PChar(Letter + ':\'), Buffer,
236
      Length(Buffer)));
237
    Result := Buffer;
238
    DriveGuidCache.Values[Letter] := Result;
239
  end;
240
end;
241
 
242
class function TfrmIndexCreator.uniqueFilename(const filename: string): string;
243
var
244
  guid: string;
245
begin
246
  if Length(filename) < 2 then
247
    exit;
248
  if filename[2] = ':' then
249
  begin
250
    guid := DriveGuid(filename[1]);
251
 
252
    Result := guid + Copy(filename, 4, Length(filename) - 3);
253
 
254
    // result := LowerCase(result);
255
  end
256
  else
257
    Result := filename; // z.B. UNC-Pfad
258
end;
259
 
260
class function TfrmIndexCreator.VtsSpecial(const filename: string): string;
261
begin
262
  Result := filename;
263
{$IFDEF VIATHINKSOFT}
264
  Result := StringReplace(Result, GUID_EHDD_A, 'EHDD:\', []);
265
  Result := StringReplace(Result, GUID_EHDD_B, 'EHDD:\', []);
266
{$ENDIF}
267
end;
268
 
269
procedure TfrmIndexCreator.CheckFile(const originalFileName,
270
  uniqueFilename: string);
271
 
272
  function DateTimeToSQL(dt: TDateTime): string;
273
  begin
274
    if dt = -1 then
275
      Result := 'NULL'
276
    else
277
      Result := conn.SQLStringEscape(DateTimetoStr(dt));
278
  end;
279
 
280
type
281
  TExistResult = (erDoesNotExist, erHadError, erChanged, erUnchanged);
282
 
283
var
284
  lastCheckedMd5: string;
285
 
286
  function Exists(const filename: string; size: int64;
287
    const modified: TDateTime): TExistResult;
288
  var
289
    q: TADODataSet;
290
  begin
291
    q := conn.GetTable('select error, size, modified, md5hash from ' + TableName
292
      + ' where filename = ' + conn.SQLStringEscape
293
      (VtsSpecial(uniqueFilename)));
294
    try
295
      if q.RecordCount = 0 then
296
        Result := erDoesNotExist
297
      else if not q.Fields[0].IsNull then
298
        Result := erHadError
299
      else if (q.Fields[1].AsString <> IntToStr(size)) or
300
      // we are combining strings because of int64
301
        (SecondsBetween(q.Fields[2].AsDateTime, UTCTimeToLocalTime(modified)
302
        ) > 2) then
303
      begin
304
        Result := erChanged
305
      end
306
      else
307
        Result := erUnchanged;
308
      lastCheckedMd5 := q.Fields[3].AsString;
309
    finally
310
      FreeAndNil(q);
311
    end;
312
  end;
313
 
314
var
315
  created, modified: TDateTime;
316
  size: int64;
317
  md5: string;
318
begin
319
  Label1.Caption := MinimizeName(originalFileName, Label1.Canvas, Label1.Width);
320
  Application.ProcessMessages;
321
 
322
  try
323
    if FileExists(uniqueFilename) then
324
      created := FileCTime_UTC(uniqueFilename)
325
    else
326
      created := -1;
327
 
328
    if FileExists(uniqueFilename) then
329
      modified := FileMTime_UTC(uniqueFilename)
330
    else
331
      modified := -1;
332
 
333
    size := GetFileSize(uniqueFilename);
334
    Inc(sumsize, size);
335
    Inc(sumfiles);
336
 
337
    if rgModus.ItemIndex = modusRecreate then
338
    begin
339
      md5 := MD5File(uniqueFilename);
340
      if not cbSimulate.Checked then
341
      begin
342
        conn.ExecSQL('INSERT INTO ' + TableName +
343
          ' (filename, size, created, modified, md5hash, error) values (' +
344
          conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
345
          IntToStr(size) + ', ' + DateTimeToSQL(UTCTimeToLocalTime(created)) +
346
          ', ' + DateTimeToSQL(UTCTimeToLocalTime(modified)) + ', ' +
347
          conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
348
      end;
349
      if cbVerboseLogs.Checked then
350
        Memo2.Lines.Add('New: ' + uniqueFilename);
351
      Inc(sumfiles_new);
352
    end
353
    else
354
    begin
355
      case Exists(uniqueFilename, size, modified) of
356
        erDoesNotExist: // File does not exist or has a different hash
357
          begin
358
            if rgModus.ItemIndex <> modusValidation then
359
              md5 := MD5File(uniqueFilename);
360
            if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
361
            then
362
            begin
363
              conn.ExecSQL('INSERT INTO ' + TableName +
364
                ' (filename, size, created, modified, md5hash, error) values ('
365
                + conn.SQLStringEscape(VtsSpecial(uniqueFilename)) + ', ' +
366
                IntToStr(size) + ', ' +
367
                DateTimeToSQL(UTCTimeToLocalTime(created)) + ', ' +
368
                DateTimeToSQL(UTCTimeToLocalTime(modified)) + ', ' +
369
                conn.SQLStringEscape(LowerCase(md5)) + ', NULL);');
370
            end;
371
            if cbVerboseLogs.Checked then
372
              Memo2.Lines.Add('New: ' + uniqueFilename);
373
            Inc(sumfiles_new);
374
          end;
375
        erHadError, erChanged:
376
          begin
377
            if rgModus.ItemIndex <> modusValidation then
378
              md5 := MD5File(uniqueFilename);
379
            if not cbSimulate.Checked and (rgModus.ItemIndex <> modusValidation)
380
            then
381
            begin
382
              conn.ExecSQL('UPDATE ' + TableName + ' SET size = ' +
383
                IntToStr(size) + ', created = ' +
384
                DateTimeToSQL(UTCTimeToLocalTime(created)) + ', modified = ' +
385
                DateTimeToSQL(UTCTimeToLocalTime(modified)) + ', md5hash = ' +
386
                conn.SQLStringEscape(LowerCase(md5)) +
387
                ', error = NULL WHERE filename = ' + conn.SQLStringEscape
388
                (VtsSpecial(uniqueFilename)) + ';');
389
            end;
390
            if cbVerboseLogs.Checked then
391
              Memo2.Lines.Add('Updated: ' + uniqueFilename);
392
            Inc(sumfiles_updated);
393
          end;
394
        erUnchanged: // Date/Time+Size has not changed
395
          begin
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
    EnableDisableControls(true);
758
  end;
759
 
760
  Beep;
761
  Label1.Caption := 'Done.';
762
  Application.ProcessMessages;
763
end;
764
 
765
procedure TfrmIndexCreator.FormClose(Sender: TObject; var Action: TCloseAction);
766
begin
767
  StopRequest := true;
768
  Action := caFree; // TODO: müssen wir warten bis der prozess angehalten ist?
769
end;
770
 
771
procedure TfrmIndexCreator.FormShow(Sender: TObject);
772
var
773
  ini: TMemIniFile;
774
begin
775
  ini := frmMain.ini;
776
  rgModus.ItemIndex := ini.ReadInteger('IndexCreator', 'DefaultMode', modusUpdate);
777
  cbNoDelete.Checked := ini.ReadBool('IndexCreator', 'DefaultCheckVanished', false);
778
  cbVerboseLogs.Checked := ini.ReadBool('IndexCreator', 'DefaultVerboseLogs', false);
779
  cbSimulate.Checked := ini.ReadBool('IndexCreator', 'DefaultSimulate', false);
780
  LabeledEdit2.Text := ini.ReadString('IndexCreator', 'DefaultDir', 'C:\');
781
end;
782
 
783
procedure TfrmIndexCreator.Button2Click(Sender: TObject);
784
begin
785
  StopRequest := true;
786
  Close;
787
end;
788
 
789
procedure TfrmIndexCreator.Button4Click(Sender: TObject);
790
var
791
  i: Integer;
792
  s: string;
793
begin
794
  sumsize := 0;
795
  sumfiles := 0;
796
  sumfiles_new := 0;
797
  sumfiles_updated := 0;
798
  sumfiles_error := 0;
799
  sumfiles_deleted := 0;
800
 
801
  Label1.Caption := 'Please wait...';
802
  Label5.Caption := '0';
803
  Label6.Caption := '0';
804
  Label7.Caption := '0';
805
  Label9.Caption := '0';
806
  Label11.Caption := '0';
807
  Label12.Caption := '0';
808
  Application.ProcessMessages;
809
 
810
  EnableDisableControls(false);
811
  try
812
    // if fileexists('tmp') then memo1.lines.LoadFromFile('tmp');
813
    for i := Memo1.Lines.Count - 1 downto 0 do
814
    begin
815
      s := Memo1.Lines.strings[i];
816
      if Trim(s) <> '' then
817
      begin
818
        LabeledEdit2.Text := s;
819
 
820
        if not SysUtils.DirectoryExists(LabeledEdit2.Text) then
821
        begin
822
          raise Exception.CreateFmt('Directory %s not found.',
823
            [LabeledEdit2.Text]);
824
        end;
825
 
826
        IndexDrive(LabeledEdit2.Text);
827
      end;
828
      Memo1.Lines.Delete(i);
829
      // memo1.lines.SaveToFile('tmp');
830
    end;
831
 
832
    (*
833
      if not Application.Terminated or StopRequest then
834
      begin
835
      ShowMessage('Finished');
836
      end;
837
    *)
838
  finally
839
    EnableDisableControls(true);
840
  end;
841
 
842
  Beep;
843
  Label1.Caption := 'Done.';
844
  Application.ProcessMessages;
845
end;
846
 
847
procedure TfrmIndexCreator.EnableDisableControls(enabled: boolean);
848
begin
849
  rgModus.enabled := enabled;
850
  cbNoDelete.enabled := enabled and (rgModus.ItemIndex <> modusValidation);
851
  cbVerboseLogs.enabled := enabled;
852
  cbSimulate.enabled := enabled and (rgModus.ItemIndex <> modusValidation);
853
  Button1.enabled := enabled;
854
  LabeledEdit2.enabled := enabled;
855
  Memo1.enabled := enabled;
856
  Button4.enabled := enabled;
857
end;
858
 
859
end.