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