WebSVN – delphiutils – Diff – /trunk/FileReadChecker/FileReadCheckerMain.pas


unit FileReadCheckerMain;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, FileCtrl, Math;
 
type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Memo1: TMemo;
    Label1: TLabel;
    Label2: TLabel;
    ProgressBar1: TProgressBar;
    procedure Button1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
  private
    procedure FindFiles(FilesList: TStrings; StartDir, FileMask: string; errorSL: TStrings=nil);
    procedure EnableDisableControls(enabled: boolean);
    function Readable(filename: string): boolean;
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
// Recursive procedure to build a list of files
procedure TForm1.FindFiles(FilesList: TStrings; StartDir, FileMask: string; errorSL: TStrings=nil);
var
  SR: TSearchRec;
  DirList: TStrings;
  IsFound: Boolean;
  i: integer;
begin
  if StartDir[length(StartDir)] <> PathDelim then
    StartDir := StartDir + PathDelim;
 
  IsFound := FindFirst(StartDir+FileMask, faAnyFile-faDirectory, SR) = 0;
  while IsFound do
  begin
    Application.ProcessMessages;
    if Application.Terminated then Abort;
 
    if FilesList.Count = FilesList.Capacity - 1 then
      FilesList.Capacity := FilesList.Capacity + 1000;
 
    FilesList.Add(StartDir + SR.Name);
    IsFound := FindNext(SR) = 0;
  end;
  FindClose(SR);
 
  // Build a list of subdirectories
  DirList := TStringList.Create;
  IsFound := FindFirst(StartDir+'*.*', faAnyFile, SR) = 0;
  if DirectoryExists(StartDir) and not IsFound then
  begin
    // Every directory has always at least 2 items ('.' and '..')
    // If not, we have an ACL problem.
    if Assigned(errorSL) then errorSL.Add(StartDir);
  end;
  while IsFound do begin
    if ((SR.Attr and faDirectory) <> 0) and
         (SR.Name[1] <> '.') then
    begin
      Application.ProcessMessages;
      if Application.Terminated then Abort;
      DirList.Add(StartDir + SR.Name);
    end;
    IsFound := FindNext(SR) = 0;
  end;
  FindClose(SR);
 
  // Scan the list of subdirectories
  for i := 0 to DirList.Count - 1 do
  begin
    FindFiles(FilesList, DirList[i], FileMask, errorSL);
  end;
 
  DirList.Free;
end;
 
function TForm1.Readable(filename: string): boolean;
var
  ss: TFileStream;
begin
  result := false;
  if not FileExists(filename) then exit;
  try
    ss := TFileStream.Create(filename, fmOpenRead or fmShareDenyNone);
    ss.Free;
    result := true;
  except
    exit;
  end;
end;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  sl: TStringList;
  fil: string;
  cnt: integer;
  c1, c2, f: Int64;
  elapsedSecs: Int64;
begin
  if not DirectoryExists(edit1.Text) then
  begin
    raise Exception.CreateFmt('Directory %s does not exist!', [Edit1.Text]);
  end;
 
  QueryPerformanceFrequency(f);
  QueryPerformanceCounter(c1);
 
  EnableDisableControls(false);
  try
    Memo1.Lines.Clear;
    cnt := 0;
    sl := TStringList.Create;
    try
      sl.Sorted := false;
      sl.BeginUpdate;
      Label2.Caption := 'Scan folders ...';
     
      FindFiles(sl, edit1.text, '*', Memo1.Lines);
      Inc(cnt, Memo1.Lines.Count); // failed folders
 
      ProgressBar1.Max := sl.Count;
      ProgressBar1.Min := 0;
      ProgressBar1.Position := 0;
 
      for fil in sl do
      begin
        ProgressBar1.Position := ProgressBar1.Position + 1;
 
        if not Readable(fil) then
        begin
          Memo1.Lines.Add(fil);
          inc(cnt);
        end;
 
        QueryPerformanceCounter(c2);
        elapsedSecs := Ceil((c2-c1)/f);
        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);
 
        Application.ProcessMessages;
        if Application.Terminated then Abort;
      end;
      sl.EndUpdate;
    finally
      sl.Free;
    end;
 
    if not Application.Terminated then
    begin
      QueryPerformanceCounter(c2);
      elapsedSecs := Ceil((c2-c1)/f);
 
      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]);
    end;
  finally
    EnableDisableControls(true);
  end;
end;
 
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Application.Terminate;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := true;
 
  {$IFDEF UNICODE}
  Caption := Caption + ' [Unicode]';
  {$ELSE}
  Caption := Caption + ' [ANSI]';
  {$ENDIF}
end;
 
procedure TForm1.EnableDisableControls(enabled: boolean);
begin
  Button1.Enabled := enabled;
  Label1.Enabled := enabled;
  Edit1.Enabled := enabled;
  // Memo1.Enabled := enabled; // is already readonly by default
end;
 
end.
 

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

Subversion Repositories delphiutils

delphiutils/trunk/FileReadChecker/FileReadCheckerMain.pas – Rev 84 → 85