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 ago) by daniel-marschall
Content type: text/x-pascal
File size: 4416 byte(s)
Log Message:
File Read Checker 1.2

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