Subversion Repositories delphiutils

Rev

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

Rev Author Line No. Line
84 daniel-mar 1 
unit FileReadCheckerMain;
2 
 
3 
interface
4 
 
5 
uses
6 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
7 
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, FileCtrl, Math;
8 
 
9 
type
10 
  TForm1 = class(TForm)
11 
    Button1: TButton;
12 
    Edit1: TEdit;
13 
    Memo1: TMemo;
14 
    Label1: TLabel;
15 
    Label2: TLabel;
16 
    ProgressBar1: TProgressBar;
17 
    procedure Button1Click(Sender: TObject);
18 
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
19 
  private
20 
    procedure FindFiles(FilesList: TStrings; StartDir, FileMask: string; errorSL: TStrings=nil);
21 
    procedure EnableDisableControls(enabled: boolean);
22 
    function Readable(filename: string): boolean;
23 
  end;
24 
 
25 
var
26 
  Form1: TForm1;
27 
 
28 
implementation
29 
 
30 
{$R *.dfm}
31 
 
32 
// Recursive procedure to build a list of files
33 
procedure TForm1.FindFiles(FilesList: TStrings; StartDir, FileMask: string; errorSL: TStrings=nil);
34 
var
35 
  SR: TSearchRec;
36 
  DirList: TStrings;
37 
  IsFound: Boolean;
38 
  i: integer;
39 
begin
40 
  if StartDir[length(StartDir)] <> PathDelim then
41 
    StartDir := StartDir + PathDelim;
42 
 
43 
  IsFound := FindFirst(StartDir+FileMask, faAnyFile-faDirectory, SR) = 0;
44 
  while IsFound do
45 
  begin
46 
    Application.ProcessMessages;
47 
    if Application.Terminated then Abort;
48 
    FilesList.Add(StartDir + SR.Name);
49 
    IsFound := FindNext(SR) = 0;
50 
  end;
51 
  FindClose(SR);
52 
 
53 
  // Build a list of subdirectories
54 
  DirList := TStringList.Create;
55 
  IsFound := FindFirst(StartDir+'*.*', faAnyFile, SR) = 0;
56 
  if DirectoryExists(StartDir) and not IsFound then
57 
  begin
58 
    // Every directory has always at least 2 items ('.' and '..')
59 
    // If not, we have an ACL problem.
60 
    if Assigned(errorSL) then errorSL.Add(StartDir);
61 
  end;
62 
  while IsFound do begin
63 
    if ((SR.Attr and faDirectory) <> 0) and
64 
         (SR.Name[1] <> '.') then
65 
    begin
66 
      Application.ProcessMessages;
67 
      if Application.Terminated then Abort;
68 
      DirList.Add(StartDir + SR.Name);
69 
    end;
70 
    IsFound := FindNext(SR) = 0;
71 
  end;
72 
  FindClose(SR);
73 
 
74 
  // Scan the list of subdirectories
75 
  for i := 0 to DirList.Count - 1 do
76 
  begin
77 
    FindFiles(FilesList, DirList[i], FileMask, errorSL);
78 
  end;
79 
 
80 
  DirList.Free;
81 
end;
82 
 
83 
function TForm1.Readable(filename: string): boolean;
84 
var
85 
  ss: TFileStream;
86 
begin
87 
  result := false;
88 
  if not FileExists(filename) then exit;
89 
  try
90 
    ss := TFileStream.Create(filename, fmOpenRead or fmShareDenyNone);
91 
    ss.Free;
92 
    result := true;
93 
  except
94 
    exit;
95 
  end;
96 
end;
97 
 
98 
procedure TForm1.Button1Click(Sender: TObject);
99 
var
100 
  sl: TStringList;
101 
  fil: string;
102 
  cnt: integer;
103 
  c1, c2, f: Int64;
104 
  elapsedSecs: Int64;
105 
begin
106 
  if not DirectoryExists(edit1.Text) then
107 
  begin
108 
    raise Exception.CreateFmt('Directory %s does not exist!', [Edit1.Text]);
109 
  end;
110 
 
111 
  QueryPerformanceFrequency(f);
112 
  QueryPerformanceCounter(c1);
113 
 
114 
  EnableDisableControls(false);
115 
  try
116 
    Memo1.Lines.Clear;
117 
    cnt := 0;
118 
    sl := TStringList.Create;
119 
    try
120 
      sl.BeginUpdate;
121 
      Label2.Caption := 'Scan folders ...';
122 
 
123 
      FindFiles(sl, edit1.text, '*', Memo1.Lines);
124 
      Inc(cnt, Memo1.Lines.Count); // failed folders
125 
 
126 
      ProgressBar1.Max := sl.Count;
127 
      ProgressBar1.Min := 0;
128 
      ProgressBar1.Position := 0;
129 
 
130 
      for fil in sl do
131 
      begin
132 
        ProgressBar1.Position := ProgressBar1.Position + 1;
133 
 
134 
        if not Readable(fil) then
135 
        begin
136 
          Memo1.Lines.Add(fil);
137 
          inc(cnt);
138 
        end;
139 
 
140 
        Label2.Caption := MinimizeName(fil, Label2.Canvas, Label2.Width);
141 
 
142 
        Application.ProcessMessages;
143 
        if Application.Terminated then Abort;
144 
      end;
145 
      sl.EndUpdate;
146 
    finally
147 
      sl.Free;
148 
    end;
149 
 
150 
    if not Application.Terminated then
151 
    begin
152 
      QueryPerformanceCounter(c2);
153 
      elapsedSecs := Ceil((c2-c1)/f);
154 
 
155 
      ShowMessageFmt('Finished. Found %d error(s). Time: %.2d:%.2d:%.2d', [cnt, elapsedSecs div 3600, elapsedSecs mod 3600 div 60, elapsedSecs mod 3600 mod 60]);
156 
    end;
157 
  finally
158 
    EnableDisableControls(true);
159 
  end;
160 
end;
161 
 
162 
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
163 
begin
164 
  Application.Terminate;
165 
end;
166 
 
167 
procedure TForm1.EnableDisableControls(enabled: boolean);
168 
begin
169 
  Button1.Enabled := enabled;
170 
  Label1.Enabled := enabled;
171 
  Edit1.Enabled := enabled;
172 
  Memo1.Enabled := enabled;
173 
end;
174 
 
175 
end.