| Autor |
Beitrag |
Gothicware
  
Beiträge: 77
Win 98, Win 2000, Win XP, BeOs-R5, Zeta 1.0(war nicht gut, also verkauft), KnoppiX, VM-Ware
D4 Client/Server, Turbo Basic, QBasic, Atari-Basic
|
Verfasst: Di 06.09.05 00:00
Hallo Delphi-Forum,
im Rahmen eines Projektes habe ich mir Datei such Unit geschrieben, die ich so gut finde,
das ich glaub es könnte auch für andere nützlich sein.
Hier dir Groben Fakten:
Man plaziert die VCL auf die eine Form, und stellt die Eigenschaften ein.
Beim Erstellen wird der Suchpfad auf den Aktuellen Ordner gesetzt.
Als Maske, sind auch MultiMasken möglich, wie '*.jpg;*.tif;*.bmp;' usw..
Die Datei Attribute können genau wie bei FindFirst angegeben werden (zb.: faAniFile).
Damit die Suche nicht das Programm einfiert kann man AbortAble auf True setzen,
dann wird in jeder Schleife einmal Application.ProcessMessages ausgeführt.
Die Suche Started man mit TGW_FileFinder.Search; vorzeitiges Abrechen mit TGW_FileFinder.Abort;
Es gibt drei Events:
  Delphi-Quelltext
1:
2:
3:
| procedure OnFileFound(Sender: TObject; Filename, Path: String; Size: Integer; CreateDateTime, LastAccessDateTime, LastWriteDateTime: TDateTime) of object;
procedure OnDirFound(Sender: TObject; Dirname, Path: String; CreateDateTime, LastAccessDateTime, LastWriteDateTime: TDateTime) of object;
procedure OnSearchDirChange(Sender: TObject; Path: String) of object; |
dadurch ist die Such-Engine sehr Flexibel einzusetzen.
Hier die Unit:
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
| unit GW_FileFinder;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
FileCtrl, Menus, StdCtrls, ExtCtrls;
type
TFileAttrKind = (faReadOnly, faHidden, faSysFile, faVolumeID,
faDirectory, faArchive, faAnyFile);
TFileAttr = set of TFileAttrKind;
TFileFound= procedure(Sender: TObject; Filename, Path: String; Size: Integer; CreateDateTime, LastAccessDateTime, LastWriteDateTime: TDateTime) of object;
TDirFound= procedure(Sender: TObject; Dirname, Path: String; CreateDateTime, LastAccessDateTime, LastWriteDateTime: TDateTime) of object;
TDirChange= procedure(Sender: TObject; Path: String) of object;
TGW_FileFinder = class(TComponent)
private
fSubFolder: Boolean;
fAttr: TFileAttr;
fPath: String;
fFileMask: String;
FOnFileFound: TFileFound;
FOnDirFound: TDirFound;
FOnSearchDirChange: TDirChange;
fFileMasks: TStringList;
fRun: Boolean;
fAbortAble: Boolean;
procedure SetFileMask(Value: string);
procedure SetPath(Value: string);
procedure FileSearch(const inPath : string);
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Search;
procedure Abort;
procedure FileFound(Filename, Path: String; Size: Integer; FindData: TWin32FindData);
procedure DirFound(Dirname, Path: String; FindData: TWin32FindData);
procedure DirChange(Path: String);
published
property OnFileFound: TFileFound read FOnFileFound write FOnFileFound;
property OnDirFound: TDirFound read FOnDirFound write FOnDirFound;
property OnSearchDirChange: TDirChange read FOnSearchDirChange write FOnSearchDirChange;
property AbortAble: Boolean read fAbortAble write fAbortAble default True;
property FileAttr: TFileAttr read fAttr write fAttr;
property InSubFolders: boolean read fSubFolder write fSubFolder;
property Path: string read fPath write SetPath;
property FileMask: string read fFileMask write SetFileMask ;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Gothicware', [TGW_FileFinder]);
end;
function IncludeTrailingBackslash(Dir: String):String;
begin
if AnsiLastChar(Dir)^ <> '\' then Result:= Dir + '\' else Result:= Dir;
end;
constructor TGW_FileFinder.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Path:= IncludeTrailingBackslash(GetCurrentDir);
SetFileMask('*.*');
fAbortAble:= True;
fRun:= False;
fFileMasks:= TStringList.Create;
FileAttr:= [faAnyFile];
end;
destructor TGW_FileFinder.Destroy;
begin
fFileMasks.Free;
inherited Destroy;
end;
procedure TGW_FileFinder.SetFileMask(Value: string);
function Explode(S, Separator: String):TStringList;
begin
result:= TStringList.Create;
result.Text:= StringReplace(S, Separator, #10#13, [rfReplaceAll]);
end;
begin
if fFileMask <> Value then
begin
fFileMask:= Value;
fFileMasks:= Explode(Value,';');
end;
end;
procedure TGW_FileFinder.Abort;
begin
fRun:= False;
end;
procedure TGW_FileFinder.Search;
begin
if fRun then if Application.MessageBox(PChar('You are already searching.' + #10#13 + 'Abort first or wait for the end of the search!'),PChar('Error'),$00000001) = 1 then Exit;
fRun:= True;
FileSearch(fPath);
fRun:= False;
end;
procedure TGW_FileFinder.FileFound(Filename, Path: String; Size: Integer; FindData: TWin32FindData);
var CreateDateTime, AccessDateTime, WriteDateTime: TDateTime;
fCreateDateTime, fAccessDateTime, fWriteDateTime: TFileTime;
sCreateDateTime, sAccessDateTime, sWriteDateTime: TSystemTime;
begin
if Assigned(FOnFileFound) then
begin
FillChar(fCreateDateTime, SizeOf(TFileTime), #0);
FillChar(fAccessDateTime, SizeOf(TFileTime), #0);
FillChar(fWriteDateTime, SizeOf(TFileTime), #0);
FileTimeToLocalFileTime(FindData.ftCreationTime, fCreateDateTime);
FileTimeToLocalFileTime(FindData.ftLastAccessTime, fAccessDateTime);
FileTimeToLocalFileTime(FindData.ftLastWriteTime, fWriteDateTime);
FileTimeToSystemTime(fCreateDateTime, sCreateDateTime);
FileTimeToSystemTime(fAccessDateTime, sAccessDateTime);
FileTimeToSystemTime(fWriteDateTime, sWriteDateTime);
CreateDateTime:= SystemTimeToDateTime(sCreateDateTime);
AccessDateTime:= SystemTimeToDateTime(sAccessDateTime);
WriteDateTime:= SystemTimeToDateTime(sWriteDateTime);
OnFileFound(Self, Filename, Path, Size, CreateDateTime, AccessDateTime, WriteDateTime);
end;
end;
procedure TGW_FileFinder.DirFound(Dirname, Path: String; FindData: TWin32FindData);
var CreateDateTime, AccessDateTime, WriteDateTime: TDateTime;
fCreateDateTime, fAccessDateTime, fWriteDateTime: TFileTime;
sCreateDateTime, sAccessDateTime, sWriteDateTime: TSystemTime;
begin
if Assigned(FOnFileFound) then
begin
FillChar(fCreateDateTime, SizeOf(TFileTime), #0);
FillChar(fAccessDateTime, SizeOf(TFileTime), #0);
FillChar(fWriteDateTime, SizeOf(TFileTime), #0);
FileTimeToLocalFileTime(FindData.ftCreationTime, fCreateDateTime);
FileTimeToLocalFileTime(FindData.ftLastAccessTime, fAccessDateTime);
FileTimeToLocalFileTime(FindData.ftLastWriteTime, fWriteDateTime);
FileTimeToSystemTime(fCreateDateTime, sCreateDateTime);
FileTimeToSystemTime(fAccessDateTime, sAccessDateTime);
FileTimeToSystemTime(fWriteDateTime, sWriteDateTime);
CreateDateTime:= SystemTimeToDateTime(sCreateDateTime);
AccessDateTime:= SystemTimeToDateTime(sAccessDateTime);
WriteDateTime:= SystemTimeToDateTime(sWriteDateTime);
OnDirFound(Self, Dirname, Path, CreateDateTime, AccessDateTime, WriteDateTime);
end;
end;
procedure TGW_FileFinder.DirChange(Path: String);
begin
if Assigned(FOnSearchDirChange) then
OnSearchDirChange(Self, Path);
end;
procedure TGW_FileFinder.SetPath(Value: string);
begin
if fPath <> Value then
begin
if Value <> '' then
if DirectoryExists(Value) then
fPath:= IncludeTrailingBackslash(Value);
end;
end;
procedure TGW_FileFinder.FileSearch(const InPath : string);
var SR: TSearchRec;
Attr,i: Integer;
Mask:String;
begin
Attr:= 0;
if faReadOnly in FileAttr then
Attr:= Attr + $00000001;
if faHidden in FileAttr then
Attr:= Attr + $00000002;
if faSysFile in FileAttr then
Attr:= Attr + $00000004;
if faVolumeID in FileAttr then
Attr:= Attr + $00000008;
if faDirectory in FileAttr then
Attr:= Attr + $00000010;
if faArchive in FileAttr then
Attr:= Attr + $00000020;
if faAnyFile in FileAttr then
Attr:= Attr + $0000003F;
DirChange(InPath);
for i:= 0 to fFileMasks.Count -1 do
if fRun then
begin
Mask:= trim(fFileMasks[i]);
if SysUtils.FindFirst(inPath + Mask, Attr, SR) = 0 then
try
repeat
if ((SR.Attr and $00000010) > 0) and (SR.Name <> '.') and (SR.Name <> '..') then
DirFound(SR.Name, inPath, SR.FindData)
else
if (SR.Name <> '.') and (SR.Name <> '..') then
FileFound(SR.Name, inPath, SR.Size, SR.FindData);
if fAbortAble then Application.ProcessMessages;
until (SysUtils.FindNext(SR) <> 0) or not fRun;
finally
SysUtils.FindClose(SR);
end;
end;
if not InSubFolders then Exit;
if SysUtils.FindFirst(inPath + '*', $00000010, SR) = 0 then
try
repeat
if ((SR.Attr and $00000010) > 0) and (SR.Name <> '.') and (SR.Name <> '..') then
begin
if fAbortAble then Application.ProcessMessages;
FileSearch(IncludeTrailingBackslash(inPath + SR.Name));
end;
until (SysUtils.FindNext(SR) <> 0) or not fRun;
finally
SysUtils.FindClose(SR);
end;
end;
end. |
Was kommt noch??
- korrektur, wenn man als Pfad nur den Anfangsbuchstaben eingibt
- bei OnFileFound und OnDirFound übergabe der Attribute und des Icons oder IconHandels
- "-------------------------------------" Übergabe des Datei/Ornder Typs als String
Weitere Anregung Herzlich Willkommen.
Euere Gothicware, Inc.
Einloggen, um Attachments anzusehen!
|
|
Luckie
Ehemaliges Mitglied
Erhaltene Danke: 1
|
Verfasst: Di 06.09.05 01:42
Ich würde es besser in einen separaten Thread auslagern. Application.ProcessMessages kann zu unvorhergesehene Verhalten des Programmes führen. Desweiteren bremst es ziemlich die Anwnendung aus, wenn du in jedem Durchgang die Nachrichtenschlage abarbeitest. In der zeit, wo man das Fenster zum Beispiel verschiebt, passiert dann nämlich gar nichts.
|
|
Gothicware 
Beiträge: 77
Win 98, Win 2000, Win XP, BeOs-R5, Zeta 1.0(war nicht gut, also verkauft), KnoppiX, VM-Ware
D4 Client/Server, Turbo Basic, QBasic, Atari-Basic
|
Verfasst: Di 06.09.05 05:07
 Luckie hat folgendes geschrieben: | Ich würde es besser in einen separaten Thread auslagern....
...Desweiteren bremst es ziemlich die Anwendung aus, wenn du in jedem Durchgang die Nachrichtenschlage abarbeitest... |
Das mit dem Thread ist bei mir schon in fester Planung, aber hat nicht die höste Pirorität  , da dies etwas Komplex ist.
Das Application.ProcessMessages ein ziemlicher Resourcen-klauer ist, ist mir bekannt.
Deshalb hab ich ja auch die Option AbortAble dazugeschrieben.
Aber bevor ich das Problem löse, will ich die Suche etwas verbessern, in dem ich immer
erst nach '*' suche, und dann das Ergebnis mit den Masken überprüfe. Den ich muss nicht ein Ordner mit 9.000 Dateien 9mal durchsuchen. 
|
|
himitsu
Beiträge: 40
|
Verfasst: Di 20.09.05 17:41
Wenn du SetFileMask mehrmals aufrufst, dann bekommst du ein nettes Memory-Leak,
denn es wird jedesmal ein TStringList-Objekt erstellt, aber ein eventuell vorhandenes altes Objekt wird nicht freigegeben.
Also wäre es besser, wenn du vorher fFileMask freigibst.
Delphi-Quelltext
1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
| procedure TGW_FileFinder.SetFileMask(Value: string);
...
begin
if fFileMask <> Value then
begin
fFileMask:= Value;
if fFileMasks <> nil then fFileMasks.Free;
fFileMasks:= Explode(Value,';');
end;
end; |
Oder besser noch ... erstelle nur ein neues Objekt, wenn noch keines existiert.
Delphi-Quelltext
1:
2:
3:
4:
5:
6:
7:
8:
9:
| procedure TGW_FileFinder.SetFileMask(Value: string);
begin
if fFileMask <> Value then
begin
fFileMask := Value;
if fFileMasks = nil then fFileMasks := TStringList.Create;
fFileMasks.Text := StringReplace(Value, ';', #10#13, [rfReplaceAll]);
end;
end; |
PS: Bei derartigen Fehlern kann dir ein Memory-Wächter helfen.  _________________ warum einfach wenn's auch kompliziert geht
schreib wie du willst und halt dich an keine standards
|
|
Gothicware
Beiträge: 77
Win 98, Win 2000, Win XP, BeOs-R5, Zeta 1.0(war nicht gut, also verkauft), KnoppiX, VM-Ware
D4 Client/Server, Turbo Basic, QBasic, Atari-Basic
|
Verfasst: Di 20.09.05 20:57
Danke *MemoryWächter*  werde es ändern. Wird aber noch etwas dauern bis ich es hochlade, da ich das ganze wie gesagt mal überarbeiten will. (wenn dafür Zeit da ist.)
|
|
|
