Login | ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/delphiutils/trunk/FileReadChecker/FileReadCheckerMain.pas
Revision: 85
Committed: Mon May 6 17:42:23 2019 UTC (7 months, 1 week ago) by daniel-marschall
Content type: text/x-pascal
File size: 5045 byte(s)
Log Message:
File Reader Checker update

File Contents

# Content
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 procedure FormCreate(Sender: TObject);
20 private
21 procedure FindFiles(FilesList: TStrings; StartDir, FileMask: string; errorSL: TStrings=nil);
22 procedure EnableDisableControls(enabled: boolean);
23 function Readable(filename: string): boolean;
24 end;
25
26 var
27 Form1: TForm1;
28
29 implementation
30
31 {$R *.dfm}
32
33 // Recursive procedure to build a list of files
34 procedure TForm1.FindFiles(FilesList: TStrings; StartDir, FileMask: string; errorSL: TStrings=nil);
35 var
36 SR: TSearchRec;
37 DirList: TStrings;
38 IsFound: Boolean;
39 i: integer;
40 begin
41 if StartDir[length(StartDir)] <> PathDelim then
42 StartDir := StartDir + PathDelim;
43
44 IsFound := FindFirst(StartDir+FileMask, faAnyFile-faDirectory, SR) = 0;
45 while IsFound do
46 begin
47 Application.ProcessMessages;
48 if Application.Terminated then Abort;
49
50 if FilesList.Count = FilesList.Capacity - 1 then
51 FilesList.Capacity := FilesList.Capacity + 1000;
52
53 FilesList.Add(StartDir + SR.Name);
54 IsFound := FindNext(SR) = 0;
55 end;
56 FindClose(SR);
57
58 // Build a list of subdirectories
59 DirList := TStringList.Create;
60 IsFound := FindFirst(StartDir+'*.*', faAnyFile, SR) = 0;
61 if DirectoryExists(StartDir) and not IsFound then
62 begin
63 // Every directory has always at least 2 items ('.' and '..')
64 // If not, we have an ACL problem.
65 if Assigned(errorSL) then errorSL.Add(StartDir);
66 end;
67 while IsFound do begin
68 if ((SR.Attr and faDirectory) <> 0) and
69 (SR.Name[1] <> '.') then
70 begin
71 Application.ProcessMessages;
72 if Application.Terminated then Abort;
73 DirList.Add(StartDir + SR.Name);
74 end;
75 IsFound := FindNext(SR) = 0;
76 end;
77 FindClose(SR);
78
79 // Scan the list of subdirectories
80 for i := 0 to DirList.Count - 1 do
81 begin
82 FindFiles(FilesList, DirList[i], FileMask, errorSL);
83 end;
84
85 DirList.Free;
86 end;
87
88 function TForm1.Readable(filename: string): boolean;
89 var
90 ss: TFileStream;
91 begin
92 result := false;
93 if not FileExists(filename) then exit;
94 try
95 ss := TFileStream.Create(filename, fmOpenRead or fmShareDenyNone);
96 ss.Free;
97 result := true;
98 except
99 exit;
100 end;
101 end;
102
103 procedure TForm1.Button1Click(Sender: TObject);
104 var
105 sl: TStringList;
106 fil: string;
107 cnt: integer;
108 c1, c2, f: Int64;
109 elapsedSecs: Int64;
110 begin
111 if not DirectoryExists(edit1.Text) then
112 begin
113 raise Exception.CreateFmt('Directory %s does not exist!', [Edit1.Text]);
114 end;
115
116 QueryPerformanceFrequency(f);
117 QueryPerformanceCounter(c1);
118
119 EnableDisableControls(false);
120 try
121 Memo1.Lines.Clear;
122 cnt := 0;
123 sl := TStringList.Create;
124 try
125 sl.Sorted := false;
126 sl.BeginUpdate;
127 Label2.Caption := 'Scan folders ...';
128
129 FindFiles(sl, edit1.text, '*', Memo1.Lines);
130 Inc(cnt, Memo1.Lines.Count); // failed folders
131
132 ProgressBar1.Max := sl.Count;
133 ProgressBar1.Min := 0;
134 ProgressBar1.Position := 0;
135
136 for fil in sl do
137 begin
138 ProgressBar1.Position := ProgressBar1.Position + 1;
139
140 if not Readable(fil) then
141 begin
142 Memo1.Lines.Add(fil);
143 inc(cnt);
144 end;
145
146 QueryPerformanceCounter(c2);
147 elapsedSecs := Ceil((c2-c1)/f);
148 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);
149
150 Application.ProcessMessages;
151 if Application.Terminated then Abort;
152 end;
153 sl.EndUpdate;
154 finally
155 sl.Free;
156 end;
157
158 if not Application.Terminated then
159 begin
160 QueryPerformanceCounter(c2);
161 elapsedSecs := Ceil((c2-c1)/f);
162
163 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]);
164 end;
165 finally
166 EnableDisableControls(true);
167 end;
168 end;
169
170 procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
171 begin
172 Application.Terminate;
173 end;
174
175 procedure TForm1.FormCreate(Sender: TObject);
176 begin
177 DoubleBuffered := true;
178
179 {$IFDEF UNICODE}
180 Caption := Caption + ' [Unicode]';
181 {$ELSE}
182 Caption := Caption + ' [ANSI]';
183 {$ENDIF}
184 end;
185
186 procedure TForm1.EnableDisableControls(enabled: boolean);
187 begin
188 Button1.Enabled := enabled;
189 Label1.Enabled := enabled;
190 Edit1.Enabled := enabled;
191 // Memo1.Enabled := enabled; // is already readonly by default
192 end;
193
194 end.