Solved

To Geobul2

Posted on 2001-07-01
3
176 Views
Last Modified: 2010-04-06
Hello

I notice the procedure is search again and again after mask until it is no more mask to find.
I want it to search all mask at the same time not to start over on a new mask.
It take to long if I have 10 file name in me search mask.



procedure GetFiles(FromDir, Mask: String; IncludeSubdirs : boolean; List: TListBox);
 var
 DirInfo: TSearchRec;
 R, ii, i: Integer;
 DirList: TStringList;

begin

 if FromDir[Length(FromDir)] <> '\' then FromDir := FromDir + '\';
 DirList := TStringList.Create;
try
if not StopFind then begin
 if IncludeSubdirs then begin
  R := FindFirst(FromDir + '*.*', faDirectory, DirInfo);
  if R = 0 then begin
   repeat
    if (DirInfo.Name <> '.') and (DirInfo.Name <> '..') then begin
      DirList.Add(FromDir + DirInfo.Name);

    end;
    R := FindNext(DirInfo);
   until R <> 0;
   FindClose(DirInfo);
  end;
 end;
 end;
 R := FindFirst(FromDir + Mask, faAnyfile, DirInfo);
form1.StatusBar1.Panels[2].Text:=FromDir + DirInfo.Name + '\';
 if R = 0 then begin
  repeat
      if not StopFind then begin
    if (DirInfo.Name <> '.') and (DirInfo.Name <> '..') then begin
      if (((DirInfo.Attr and faDirectory) <> 0) and IncludeSubdirs) then GetFiles(FromDir + DirInfo.Name
+ '\', Mask, IncludeSubdirs, List)

        else List.Items.Add(FromDir + DirInfo.Name);
      end;
    end;
    R := FindNext(DirInfo);
  until R <> 0;
  FindClose(DirInfo);
 end;
Application.ProcessMessages;
 if not StopFind then begin
  if IncludeSubdirs then begin
   for i := 0 to DirList.Count - 1 do begin
     GetFiles(DirList[i], Mask, IncludeSubdirs, List);
       for ii := 0 to form1.lbFiles.Items.Count  do begin
        form1.StatusBar1.Panels[1].Text:='Files found: ' + IntToStr(ii);
        end;
    end;
  end;
 end;
finally
  DirList.Free;
 end;
end;

function SplitStr(Var AString : String; ADelim : String) : String;
 var APos : Integer;
 begin
  Result := '';
  APos := Pos(ADelim,AString);
 if APos > 0 then begin
  Result := Copy(AString,1,APos-1);
  AString := copy(Astring,APos+length(Adelim),MaxLongInt);
end else begin
  Result := AString;
  AString := '';
  end;
  end;


procedure TForm1.Button1Click(Sender: TObject);
var
 s, Mask: string;
 //xx : Integer;
begin
  StopFind := false;
  //Screen.Cursor := crAppStart;
  lbFiles.Items.Clear;
  s := edtMask.Text;
 while s <> '' do begin
   Mask := SplitStr(s,';');
   GetFiles(edtPath.Text,Mask,cbSubdirs.Checked,lbFiles);
 end;
  if StopFind then lbFiles.Items.Clear;
   //Screen.Cursor := crDefault;
   form1.StatusBar1.Panels[1].Text:='Search done'
end;
0
Comment
Question by:Dark_King
  • 2
3 Comments
 
LVL 14

Expert Comment

by:AvonWyss
ID: 6243851
How will such a Mask look like?
0
 
LVL 2

Expert Comment

by:bugroger
ID: 6243977
Hi,

Try this function to get the files.
You must search with findfirst and findnext for "*.*"
and then look if the mask of the founded file is in
your MaskString.


ex.: "GetFiles('C:\DIR', '*.txt;*.exe;*.html', TRUE, Memo1);


Procedure GetFiles(Dir, FileMask : String; RecurseSubDirs : Boolean; TestMemo : TMemo);
 Function InFileMaskString(s : string) : Boolean;
 Var
  i : Integer;
 Begin
  Result := FALSE;
  Repeat
   i := Pos(s, FileMask);
   IF i <> 0 then
    IF (FileMask[i] = '.')and(FileMask[i + Length(s)] = ';') then
    Begin
     i := 0;
     Result := TRUE;
    End;
  Until i = 0;
 End;


 Procedure _GetFiles(StartDir : string);
 var
  SR : tSearchRec;
  ERG : integer;

 begin
  IF StartDir[Length(StartDir)]<>'\' then StartDir := StartDir + '\';

  ERG := findfirst(StartDir+'*.*', faANYFILE, SR);
  While (ERG = 0) do
  begin
   //IF it a directory and RECURSESUBDIRS then step in
   IF (SR.Attr and faDirectory > 0)and(SR.Name[1] <> '.')and RecurseSubDirs
     then _GetFiles(StartDir + SR.Name)
     else
   //else
   IF (SR.Name[1] <> '.')and(InFileMaskString(ExtractFileExt(SR.Name)))then
   Begin
    TestMemo.Lines.Add(StartDir + SR.Name);
   End;
   ERG := FindNext(SR);
   Application.ProcessMessages;
  end;
  FindClose(SR);
 end;
Begin
 IF FileMask[Length(FileMask)] <> ';' then FileMask := FileMask + ';';
 _GetFiles(Dir);
End;

GL
 Bug
0
 
LVL 14

Accepted Solution

by:
AvonWyss earned 200 total points
ID: 6244349
bugroger, your code will only work with extensions and will not handle all of them right. For instance, if I supply "*.*" or *.~*", it will return 0 results. If I search for "bs*.pas", it will return all PAS files, not only the ones beginning with "bs". And one-char wildcards are not supported either: "*.?as" should return all ".pas", ".bas" etc. files, but will yield 0 results with your code.

Dark_King, you need a "simple" pattern matching routine to do the checks. I have done one myself which is very flexible and fast. It's attached below.

For your type of masks, you need to use MultiMatch. The normal Match will only match a single pattern to a string; MultiMatch will match a series of patterns separated by a given separator to a string.


{ (C) 2001 by Ars?ne von Wyss - avw@gmx.ch (EE member AvonWyss)

Provided AS-IS without any implicit or explicit warranty; use at your own risk.
You are not allowed to sell this source code or any part of it.
The source code may be redistributed as long as the copyright notice and this disclaimer remains intact.}

unit Matching;

interface

uses
      Windows,SysUtils;

type
      PCases=^TCases;
      TCases=array[Char] of Char;

var
      NCases,LCases,UCases: TCases;

function Match(const Pattern,S: string; CaseSensitive: Boolean=False; WildCard: Char='*'; CharCard: Char='?'): Boolean;
function MultiMatch(const Patterns,S: string; Separator: Char=';'; TrimSpaces: Boolean=True; CaseSensitive: Boolean=False; WildCard: Char='*'; CharCard: Char='?'): Boolean;
function CharString(C: Char; Count: Integer): string;

implementation

function CharString(C: Char; Count: Integer): string;
begin
      if Count>0 then begin
            SetLength(Result,Count);
            FillChar(Pointer(Result)^,Count,C);
      end;
end;

function MultiMatch(const Patterns,S: string; Separator: Char; TrimSpaces,CaseSensitive: Boolean; WildCard,CharCard: Char): Boolean;
var
      Left,Right,UseRight: Integer;
      Pattern: string;
begin
      Result:=False;
      Left:=1;
      while (not Result) and (Left<=Length(Patterns)) do begin
            if TrimSpaces then
                  while (Left<=Length(Patterns)) and (Patterns[Left]=' ') do
                        Inc(Left);
            Right:=Left;
            UseRight:=Left;
            while (Right<=Length(Patterns)) and (Patterns[Right]<>Separator) do begin
                  if (Patterns[Right]<>' ') or (not TrimSpaces) then
                        UseRight:=Right;
                  Inc(Right);
            end;
            Pattern:=Copy(Patterns,Left,UseRight-Left+1);
            if Pattern<>'' then
                  Result:=Match(Pattern,S,CaseSensitive,WildCard,CharCard)
            else
                  Result:=S='';
(Pattern,S,CaseSensitive,WildCard,CharCard);
            Left:=Right+1;
      end;
end;

function Match(const Pattern,S: string; CaseSensitive: Boolean; WildCard,CharCard: Char): Boolean;
var
      Cases: PCases;
      LP,RP,TP,LS,RS,TS: ^Char;
begin
      Assert(CharCard<>WildCard);
      if Pattern='' then begin
            Result:=S='';
            Exit;
      end;
      if S='' then begin
            Result:=Pattern=CharString(WildCard,Length(Pattern));
            Exit;
      end;
      if CaseSensitive then
            Cases:=@NCases
      else
            Cases:=@UCases;
      LP:=Pointer(Pattern);
      RP:=LP;
      Inc(RP,Length(Pattern)-1);
      LS:=Pointer(S);
      RS:=LS;
      Inc(RS,Length(S)-1);
      while (Cardinal(RP)>=Cardinal(LP)) and (Cardinal(RS)>=Cardinal(LS)) and //still in range
                        (LP^<>WildCard) and ((LP^=CharCard) or (Cases[LP^]=Cases[LS^])) do begin //matches left side
            Inc(LP);
            Inc(LS);
      end;
      while (Cardinal(RP)>=Cardinal(LP)) and (Cardinal(RS)>=Cardinal(LS)) and //still in range
                        (RP^<>WildCard) and ((RP^=CharCard) or (Cases[RP^]=Cases[RS^])) do begin //matches right side
            Dec(RP);
            Dec(RS);
      end;
      if (Cardinal(RP)<Cardinal(LP)) or (Cardinal(RS)<Cardinal(LS)) or (RP^<>WildCard) or (LP^<>WildCard) then begin
            Result:=((Cardinal(RP)<Cardinal(LP)) and (Cardinal(RS)<Cardinal(LS)));
            Exit;
      end;
      while (Cardinal(RP)>=Cardinal(LP)) and (RP^=WildCard) do
            Dec(RP);
      while (Cardinal(RP)>=Cardinal(LP)) and (LP^=WildCard) do
            Inc(LP);
      if Cardinal(RP)<Cardinal(LP) then begin
            Result:=True;
            Exit;
      end;
      Inc(RS);
      Dec(LS);
      Inc(RP);
      repeat
            repeat
                  Inc(LS);
            until (Cardinal(LS)>=Cardinal(RS)) or (Cases[LS^]=Cases[LP^]) or (Cases[LS^]=CharCard);
            if Cardinal(LS)>Cardinal(RS)-(Cardinal(RP)-Cardinal(LP)) then begin
                  Result:=False;
                  Exit;
            end;
            TS:=LS;
            Inc(TS);
            TP:=LP;
            Inc(TP);
            if Cardinal(TP)>=Cardinal(RP) then begin
                  Result:=TS=RS;
                  Exit;
            end;
            while ((Cases[TS^]=Cases[TP^]) or (Cases[TS^]=CharCard)) and (TP^<>WildCard) do begin
                  Inc(TS);
                  Inc(TP);
                  if Cardinal(TP)>=Cardinal(RP) then begin
                        Result:=True;
                        Exit;
                  end;
            end;
            if TP^=WildCard then begin
                  LS:=TS;
                  LP:=TP;
                  while (Cardinal(LP)<Cardinal(RP)) and (LP^=WildCard) do
                        Inc(LP);
            end;
      until Cardinal(LP)>=Cardinal(RP);
      Result:=True;
end;

procedure InitTables;
var
      C: Char;
begin
      for C:=Low(C) to High(C) do
            NCases[C]:=C;
      LCases:=NCases;
      CharLowerBuff(Pointer(@LCases),SizeOf(LCases));
      UCases:=NCases;
      CharUpperBuff(Pointer(@UCases),SizeOf(UCases));
end;

initialization
      InitTables;
end.
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
How to disable mouse scroll in a combo box field within a Delphi cxGrid 4 111
Delphi TcxGrid group footer summary 3 213
code issue 8 100
Strange behavior when a form is closed 6 51
This article explains how to create forms/units independent of other forms/units object names in a delphi project. Have you ever created a form for user input in a Delphi project and then had the need to have that same form in a other Delphi proj…
Introduction Raise your hands if you were as upset with FireMonkey as I was when I discovered that there was no TListview.  I use TListView in almost all of my applications I've written, and I was not going to compromise by resorting to TStringGrid…
This Micro Tutorial will give you a basic overview how to record your screen with Microsoft Expression Encoder. This program is still free and open for the public to download. This will be demonstrated using Microsoft Expression Encoder 4.
Migrating to Microsoft Office 365 is becoming increasingly popular for organizations both large and small. If you have made the leap to Microsoft’s cloud platform, you know that you will need to create a corporate email signature for your Office 365…

863 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

25 Experts available now in Live!

Get 1:1 Help Now