Subversion Repositories indexer_suite

Rev

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