Entwickler-Ecke

Open Source Units - GW_FileFinder (und noch eine Datei such Unit) ;-)


Gothicware - Di 06.09.05 00:00
Titel: GW_FileFinder (und noch eine Datei such Unit) ;-)
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:

Delphi-Quelltext 
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;
{
      /####| The
    .#   "#
    #                   /   #/      *|
   ##                  #   /#|      *|                .
   #|           ___  /*#__  #|__          _.         ###    .        .     _.
   #|         /#""#\   # #  ##`"#   #|   #`#*  ##      #   #" #   *#/*#  .# #|
   ## #####   ##  ##   # ´  #|  #   #   #` "   |#  #  |#     _#|  ´#     ####*
   |#    |#   ##  ##   #    #|  #   #   #       # .#. #`   #* #|   #     #
    *#   |#   ##  ##   #    #|  #   #   #|      # #"# #   ##  *    #     #.
     "#  |#   \#  #/   #.   #|  #   #\  ´#___   ### ###   #|  #|  .#     *#__
       "###.   \##/    \*.  "\  #   ##   ´*"    ### ###   *#  ##  *#      "*
                                #\          [UltimativeFreak]#.     ,INC. 2005
                                 ` .__________.
                         ._________|##########|_________.
 .______            .____|###########[ INFO ]###########|____.            ______.
 |######|___________|#[Unit: GW_FileFinder.pas]#[05.09.2005]#|___________|######|
 |#$$$$####################################################################$$$$#|
 |##$$$#""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""#$$$##|
   |#$$#                                                                  #$$#|
   |#$$#  GW_FileFinder.pas Copyright (c) 2005 by Gothicware, Inc.        #$$#|
   |#$$#  written by UltimativeFreak     E-mail: gothicware@web.de        #$$#|
   |#$$#                                                                  #$$#|
   |#$$#  Free use for non racialist and unexploiting Sofware!*           #$$#|
   |#$$#  *(as long you keep a the Copyright notice somewhere in your     #$$#|
   |#$$#   software manuel or readme file.)                               #$$#|
   |#$$#                                                                  #$$#|
   |#$$#  Use it at your own risk, with out any warranty!                 #$$#|
   |#$$#                                                                  #$$#|
   |#$$#  Please remember:                                                #$$#|
   |#$$#  Sofware is like Sex, it's better if it's FREE! ;-)              #$$#|
   |#$$#                                                                  #$$#|
   |#$$#  Simpel use:                                                     #$$#|
   |#$$#  - put it somwwhere on your Form                                 #$$#|
   |#$$#  - edit the propertys                                            #$$#|
   |#$$#  - assign to the procedures OnDirFound, OnFileFound,             #$$#|
   |#$$#    OnSearchDirChange                                             #$$#|
   |#$$#  - Start searching by TGW_FileFinder.Search;                     #$$#|
   |#$$#  - Abort search by TGW_FileFinder.Abort;                         #$$#|
   |#$$#                                                                  #$$#|
   |#$$#  - any thing else you can learn by using ;-P                     #$$#|
   |#$$#                                                                  #$$#|
 ._|#$$#                                                                  #$$#|_.
 |##############################################################################|
 |##############################################################################|
 °""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""°
}

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
    { Private declarations }
    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
    { Protected declarations }
  public
    { Public declarations }
    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
    { Published declarations }
    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
    // Please do not ask me about below, it wasn't my idea to make the FileTime formats
    // so tricky ;-) immersed in Delphi and WinAPI, UltimativeFreak.
    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
    // Please do not ask me about below, it wasn't my idea to make the FileTime formats
    // so tricky ;-) immersed in Delphi and WinAPI, UltimativeFreak.
    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.


Delete - 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 - Di 06.09.05 05:07
user profile iconLuckie 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 :twisted:, 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. 8)


himitsu - 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. ;)


Gothicware - Di 20.09.05 20:57
Danke *MemoryWächter* :rofl: 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.)


Entwickler-Ecke.de based on phpBB
Copyright 2002 - 2011 by Tino Teuber, Copyright 2011 - 2025 by Christian Stelzmann Alle Rechte vorbehalten.
Alle Beiträge stammen von dritten Personen und dürfen geltendes Recht nicht verletzen.
Entwickler-Ecke und die zugehörigen Webseiten distanzieren sich ausdrücklich von Fremdinhalten jeglicher Art!