Login | ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/delphiutils/trunk/FileReadChecker/FileReadCheckerMain.pas
Revision: 84
Committed: Fri May 3 12:26:45 2019 UTC (3 years, 6 months ago) by daniel-marschall
Content type: text/x-pascal
File size: 4416 byte(s)
Log Message:
File Read Checker 1.2

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