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