Subversion Repositories delphiutils

unit FileReadCheckerMain;

interface

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, StdCtrls, ComCtrls, ExtCtrls, FileCtrl, Math;

type

  TForm1 = class(TForm)

    Button1: TButton;

    Edit1: TEdit;

    Memo1: TMemo;

    Label1: TLabel;

    Label2: TLabel;

    ProgressBar1: TProgressBar;

    procedure Button1Click(Sender: TObject);

    procedure FormClose(Sender: TObject; var Action: TCloseAction);

    procedure FormCreate(Sender: TObject);

  private

    procedure FindFiles(FilesList: TStrings; StartDir, FileMask: string; errorSL: TStrings=nil);

    procedure EnableDisableControls(enabled: boolean);

    function Readable(filename: string): boolean;

  end;

var

  Form1: TForm1;

implementation

{$R *.dfm}

// Recursive procedure to build a list of files

procedure TForm1.FindFiles(FilesList: TStrings; StartDir, FileMask: string; errorSL: TStrings=nil);

var

  SR: TSearchRec;

  DirList: TStrings;

  IsFound: Boolean;

  i: integer;

begin

  if StartDir[length(StartDir)] <> PathDelim then

    StartDir := StartDir + PathDelim;

  IsFound := FindFirst(StartDir+FileMask, faAnyFile-faDirectory, SR) = 0;

  while IsFound do

  begin

    Application.ProcessMessages;

    if Application.Terminated then Abort;

    if FilesList.Count = FilesList.Capacity - 1 then

      FilesList.Capacity := FilesList.Capacity + 1000;

    FilesList.Add(StartDir + SR.Name);

    IsFound := FindNext(SR) = 0;

  end;

  FindClose(SR);

  // Build a list of subdirectories

  DirList := TStringList.Create;

  IsFound := FindFirst(StartDir+'*.*', faAnyFile, SR) = 0;

  if DirectoryExists(StartDir) and not IsFound then

  begin

    // Every directory has always at least 2 items ('.' and '..')

    // If not, we have an ACL problem.

    if Assigned(errorSL) then errorSL.Add(StartDir);

  end;

  while IsFound do begin

    if ((SR.Attr and faDirectory) <> 0) and

         (SR.Name[1] <> '.') then

    begin

      Application.ProcessMessages;

      if Application.Terminated then Abort;

      DirList.Add(StartDir + SR.Name);

    end;

    IsFound := FindNext(SR) = 0;

  end;

  FindClose(SR);

  // Scan the list of subdirectories

  for i := 0 to DirList.Count - 1 do

  begin

    FindFiles(FilesList, DirList[i], FileMask, errorSL);

  end;

  DirList.Free;

end;

function TForm1.Readable(filename: string): boolean;

var

  ss: TFileStream;

begin

  result := false;

  if not FileExists(filename) then exit;

  try

    ss := TFileStream.Create(filename, fmOpenRead or fmShareDenyNone);

    ss.Free;

    result := true;

  except

    exit;

  end;

end;

procedure TForm1.Button1Click(Sender: TObject);

var

  sl: TStringList;

  fil: string;

  cnt: integer;

  c1, c2, f: Int64;

  elapsedSecs: Int64;

begin

  if not DirectoryExists(edit1.Text) then

  begin

    raise Exception.CreateFmt('Directory %s does not exist!', [Edit1.Text]);

  end;

  QueryPerformanceFrequency(f);

  QueryPerformanceCounter(c1);

  EnableDisableControls(false);

  try

    Memo1.Lines.Clear;

    cnt := 0;

    sl := TStringList.Create;

    try

      sl.Sorted := false;

      sl.BeginUpdate;

      Label2.Caption := 'Scan folders ...';

      FindFiles(sl, edit1.text, '*', Memo1.Lines);

      Inc(cnt, Memo1.Lines.Count); // failed folders

      ProgressBar1.Max := sl.Count;

      ProgressBar1.Min := 0;

      ProgressBar1.Position := 0;

      for fil in sl do

      begin

        ProgressBar1.Position := ProgressBar1.Position + 1;

        if not Readable(fil) then

        begin

          Memo1.Lines.Add(fil);

          inc(cnt);

        end;

        QueryPerformanceCounter(c2);

        elapsedSecs := Ceil((c2-c1)/f);

        Label2.Caption := MinimizeName(Format('[%.2d:%.2d:%.2d] %s', [elapsedSecs div 3600, elapsedSecs mod 3600 div 60, elapsedSecs mod 3600 mod 60, fil]), Label2.Canvas, Label2.Width);

        Application.ProcessMessages;

        if Application.Terminated then Abort;

      end;

      sl.EndUpdate;

    finally

      sl.Free;

    end;

    if not Application.Terminated then

    begin

      QueryPerformanceCounter(c2);

      elapsedSecs := Ceil((c2-c1)/f);

      ShowMessageFmt('Finished. Found %d error(s). Elapsed time: %.2d:%.2d:%.2d', [cnt, elapsedSecs div 3600, elapsedSecs mod 3600 div 60, elapsedSecs mod 3600 mod 60]);

    end;

  finally

    EnableDisableControls(true);

  end;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

  Application.Terminate;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

  DoubleBuffered := true;

  {$IFDEF UNICODE}

  Caption := Caption + ' [Unicode]';

  {$ELSE}

  Caption := Caption + ' [ANSI]';

  {$ENDIF}

end;

procedure TForm1.EnableDisableControls(enabled: boolean);

begin

  Button1.Enabled := enabled;

  Label1.Enabled := enabled;

  Edit1.Enabled := enabled;

  // Memo1.Enabled := enabled; // is already readonly by default

end;

end.