Annotation of: delphiutils/trunk/FileReadChecker/FileReadCheckerMain.pas

Revision:	85
Committed:	Mon May 6 17:42:23 2019 UTC (3 years ago) by daniel-marschall
Content type:	text/x-pascal
File size:	5045 byte(s)
Log Message:	File Reader Checker update

File Contents

#	User	Rev	Content
1	daniel-marschall	84	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	daniel-marschall	85	procedure FormCreate(Sender: TObject);
20	daniel-marschall	84	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	daniel-marschall	85
50			if FilesList.Count = FilesList.Capacity - 1 then
51			FilesList.Capacity := FilesList.Capacity + 1000;
52
53	daniel-marschall	84	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	daniel-marschall	85	sl.Sorted := false;
126	daniel-marschall	84	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	daniel-marschall	85	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	daniel-marschall	84
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	daniel-marschall	85	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	daniel-marschall	84	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	daniel-marschall	85	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	daniel-marschall	84	procedure TForm1.EnableDisableControls(enabled: boolean);
187			begin
188			Button1.Enabled := enabled;
189			Label1.Enabled := enabled;
190			Edit1.Enabled := enabled;
191	daniel-marschall	85	// Memo1.Enabled := enabled; // is already readonly by default
192	daniel-marschall	84	end;
193
194			end.