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

Revision:	84
Committed:	Fri May 3 12:26:45 2019 UTC (3 years, 3 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.