stoppe procedure

while BlivVed do
begin

end;

...og så skal du selvfølgelig også huske at behandle messages mens din handling kører, så den knap rent faktisk registrerer klikket. Hvis du ikke har smidt den handling ud i en separat tråd (det bør du nok), så kræver det en Application.ProcessMessages på et passende tidspunkt.

Det smukkeste er at lave søgerutinen som en tråd. Lidt mere besværligt men meget flottere resultat.

Enig med hrc, og det er ikke så svært igen, så længe man er opmærksom

http://google.com/search?q=delphi+thread+tutorial

Jeg er ikke sikker på at jeg forstår.
Eller stiller spm. korrekt.

Jeg her en proc der gennemsøger drev/mapper/undermapper efter filer.
Hvis jeg søger på C: tager søgningen nogle minutter. men hvis jeg kommer i tanke om at jeg vil ændre søgekrit skal søgningen først stoppes.???

Håber dette forklarer hvad jeg vil.!

Ja, det kan du med tråde ;)

(og med martinlind/pidgeots svar)

jeg vil da gerne være vært med en findfirst..findnext..findclose lavet i en tråd som du kan stoppe og gøre ved med :

unit ThreadSearch;

interface

uses
  Classes, SysUtils;

type
  TFileFoundEvent = procedure(const FileName: TFileName; const SearchRec: TSearchRec) of object;

  TSerachThread = class(TThread)
  private
    FPath : String;
    FFileMask : TFileName;
    FDirMask : String;
    FAttr : Integer;
    FRecurse : Boolean;
    FWantAllDirs : Boolean;
    FOnFileFound :TFileFoundEvent;
    procedure SetPath(const Value: String);

    Procedure Recurse (const aPath : String); overload;
    Procedure Recurse (const aPath : String; FilesInDir : Integer; Tmp : String; Attr : Integer ); overload;
  protected
    procedure Execute; override;
  public
    Constructor Create;
    Destructor Destroy; override;
    Procedure Start;
    Procedure Stop;
  published
    property Path        : String          read  FPath        write SetPath;
    property FileMask    : TFileName      read  FFileMask    write FFileMask;
    property DirMask    : String          read  FDirMask    write FDirMask;
    property Attr        : Integer        read  FAttr        write FAttr;
    property RecurseDir  : Boolean        read  FRecurse    write FRecurse;
    property WantAllDirs : Boolean        read  FWantAllDirs write FWantAllDirs;
    property OnFileFound : TFileFoundEvent read  FOnFileFound write FOnFileFound;
  end;

implementation

{ TSerachThread }

constructor TSerachThread.Create;
begin
  FileMask        := '*.*';
  DirMask        := '*.*';
  Attr            := faAnyFile;
  RecurseDir      := True;
  FreeOnTerminate := True;
  WantAllDirs    := False;
  Path            := ExtractFilePath(ParamStr(0));
  inherited Create(True);
end;

destructor TSerachThread.Destroy;
begin
inherited Destroy;
end;

procedure TSerachThread.Execute;
begin
  if not Assigned(FOnFileFound) then
    Exception.Create(Self.ClassName + ': No callback procedure defined !!!');

if WantAllDirs then
  Recurse (FPath)
else
  Recurse (FPath, 0, FPath, 0);
end;

procedure TSerachThread.Recurse(const aPath: String; FilesInDir: Integer; Tmp: String; Attr: Integer);
var
  FSearchRec : TSearchRec;
  Res : integer;
begin
  Res := FindFirst (aPath + FFileMask, faAnyFile, FSearchRec);

  while (Res = 0) and (not Terminated) do
  begin
    if (FSearchRec.Name[1] <> '.') and  (FSearchRec.Attr and FAttr > 0 ) then
    begin
      if FSearchRec.Attr and (faAnyFile-faDirectory) <> 0 then
      begin
        inc(FilesInDir);
        if (FilesInDir = 0) then
          FOnFileFound (Tmp, FSearchRec);
      end;

      FOnFileFound (aPath + FSearchRec.Name, FSearchRec);
    end;

    Res := FindNext (FSearchRec);
  end;//while

  FindClose (FSearchRec);

  if (FRecurse) and (not Terminated) then
  begin
    Res := FindFirst (aPath + FDirMask, faAnyFile, FSearchRec);

    while (Res = 0)  and (not Terminated ) do
    begin
      if (FSearchRec.Name[1] <> '.') and (FSearchRec.Attr and faDirectory > 0) then
      begin
        FilesInDir := 0;

        if FSearchRec.Attr and FAttr  <> 0 then
        begin
          Tmp := aPath + FSearchRec.Name+'\';
          Attr := FSearchRec.Attr;
        end;

        Recurse (aPath + FSearchRec.Name+'\', FilesInDir, Tmp, Attr);
      end;

      Res := FindNext (FSearchRec);
    end;

    FindClose (FSearchRec);
  end;
end;

procedure TSerachThread.Recurse(const aPath: String);
var
  FSearchRec : TSearchRec;
  Res : integer;
begin
  Res := FindFirst (aPath +FFileMask, faAnyFile, FSearchRec);

  while (Res = 0) and (not Terminated) do
  begin
    if (FSearchRec.Name[1] <> '.') and  (FSearchRec.Attr and FAttr > 0 ) then
    begin
      if FSearchRec.Attr and (faAnyFile-faDirectory) <> 0 then
        FOnFileFound (aPath + FSearchRec.Name, FSearchRec);
    end;

    Res := FindNext (FSearchRec);
  end;//while

  FindClose (FSearchRec);

  if (FRecurse) and (not Terminated ) then
  begin
    Res := FindFirst (aPath + FDirMask, faAnyFile, FSearchRec);

    while (Res = 0)  and (not Terminated ) do
    begin
      if (FSearchRec.Name[1] <> '.') and (FSearchRec.Attr and faDirectory <> 0) then
      begin
        if FSearchRec.Attr and FAttr  <> 0 then
          FOnFileFound (aPath + FSearchRec.Name, FSearchRec);

        Recurse (aPath + FSearchRec.Name+'\');
      end;//if

      Res := FindNext (FSearchRec);
    end;//while
    FindClose (FSearchRec);
  end;//if
end;

procedure TSerachThread.SetPath(const Value: String);
begin
  FPath := IncludeTrailingBackslash(Value);
end;

procedure TSerachThread.Start;
begin
  Resume;
end;

procedure TSerachThread.Stop;
begin
  Terminate;
end;

end.

Jens B

borrisholt: Jeg har haft store problemer med at få resume til at virke. Bruger jeg Suspended := false virker det fint. Har du testet ovenstående?

Desuden burde IncludeTrailingBackslash erstattes med IncludeTrailingPathDelimiter og indføjes i kaldet til Recurse - sådan bare for konsekvensens skyld. Ellers ligner det noget jeg kunne have lavet :-)

Ja ovenstående er meget testet .. Dog tror jeg aldrig jeg har brugt resume ... kun terminate

Ok jeg er sq ikke haj nok til lige at gennemskue dette

Som jeg kan se skal unitten ThreadSearch køre ved siden af min form/unit og kaldes derfra.

men jeg kan ikke lige se hvordan jeg kalder dens procedurer (søg, start, stop)

Desværre behøver jeg lidt mere hjælp.

MVH Lars

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ThreadSearch, StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    Search: TSerachThread;
  public
    procedure OnSearchFileFound(const FileName: TFileName; const SearchRec: TSearchRec);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Search.Suspended then
    Button1.Caption := 'Pause'
  else
    Button1.Caption := 'Start';

  Search.Suspended := not Search.Suspended;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Search := TSerachThread.Create;
  Search.Path := 'C:\';
  Search.OnFileFound := OnSearchFileFound;
end;

procedure TForm1.OnSearchFileFound(const FileName: TFileName; const SearchRec: TSearchRec);
begin
  Memo1.Lines.Add(FileName)
end;

end.

Sånt :D

Den stopper godtnok, men den fortsætter med de samme kriterier.

Det jeg har behov for er at stoppe og indsætte nye kriterier(søgemappe/drev) og derefter starte forfra med nye krit

Nååe så skal du terminere tråden ikke pause den ... Så skal du bare sætte den op igen

sætte den op igen?

hestetoften : jeg har fået følgende til at virke ud fra borrisholt's kode :

Indsæt en knap mere på din form og kald den for Stop eller Terminate.

Jeg har Lavet en PROCEDURE det hedder StartAgain - Som bliver kaldt i FormCreate og
Button2 PROCEDURE'ne

----------------------------------------------------------------

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ThreadSearch, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
    Search: TSerachThread;
  public
    { Public declarations }
    procedure OnSearchFileFound(const FileName: TFileName; const SearchRec: TSearchRec);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

Procedure StartAgain;
begin
Form1.Search := TSerachThread.Create;
Form1.Search.Path := 'C:\';
Form1.Search.OnFileFound := Form1.OnSearchFileFound;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
StartAgain;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
If Search.suspended Then

  Form1.Button1.Caption := 'Start'
else
  Form1.Button1.Caption := 'Pause';

Search.suspended := not Search.suspended;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Search.Terminate;
Form1.Button1.Caption := 'Start';
showMessage('Process Stopped');
StartAgain;
end;

procedure TForm1.OnSearchFileFound(const FileName: TFileName; const SearchRec: TSearchRec);
begin
Memo1.Lines.Add(FileName);
end;

end.

----------------------------------------------------------------

borrisholt tror faktisk jeg har forstået det der med Thread, skal dog lige lege lidt mere med det :D

//Michael.

UPS - Lille rettelse :

procedure TForm1.Button1Click(Sender: TObject);
begin
If Search.suspended Then

  Form1.Button1.Caption := 'Start'
else
  Form1.Button1.Caption := 'Pause';

Search.suspended := not Search.suspended;
end;

Skal laves til (Om bytning på start og pause):

procedure TForm1.Button1Click(Sender: TObject);
begin
If Search.suspended Then

  Form1.Button1.Caption := 'Pause'
else
  Form1.Button1.Caption := 'Start';

Search.suspended := not Search.suspended;
end;

Sådan :-)

Leger lige lidt med det

Mange tak for hjælpen

Læg et svar

Jeg syntes det er mest fair hvis det er

borrisholt det får points. :-)

//Michael.

Fint nok jeg trænger også så voldsomt ;o)

Jens Borrisholt

Jeg det var nemlig det jeg tænkte :D

//Michael.