Subversion Repositories indexer_suite

Rev

Rev 4 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed

  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.
  859.