Mi busca si lo hace varias veces
 

Mi busca si lo hace varias veces y deberia ser solo una vez. Uso el SearchRecord. Este programa yo no lo hecho, pero otra persona, yo estoy solo haciendo unos arreglos en el. Anejo los fuentes. Son solo dos Units. Una el Main y otra donde están las classes y etecetera. El Main tiene una Procedure llamada OnFile. Es esta la Proc principal. Ella llama algunos recursos en la Unit FileFinder, donde están las classes, properties y etecetera. Quando se va a cambiar las extensiones de TIF para HFT, deberia hacer una sola vez para cada dato, pero estas haciendo varias vezes para cada Dato, lo que tiene um tiempo mui grande para el proceso. Gracias a todos, dudas quanto al funcionamiento, solo hacer un post que yo ayudo.

Código Delphi [-]
procedure TfMain.btnGerarClick(Sender: TObject);
begin
  GerarHFT(edtPath.Directory)
end;

procedure TfMain.FormCreate(Sender: TObject);
begin
  fConfig := TConfig.CreateFrom;

  fFindFiles := TFileFinder.Create;
  fFindFiles.OnFile := OnFile;

  fJob := THotFolderJob.Create(fConfig.ArquivoModelo);
  fJob.MarcadorPath := fConfig.PathMarcadorMacro;
  fJob.MarcadorJobName := ExtractFileName
    (ExcludeTrailingPathDelimiter(fConfig.PathMarcadorMacro));
end;

procedure TfMain.FormDestroy(Sender: TObject);
begin
  fJob.Free;
  fFindFiles.Free;
  fConfig.Free;
end;

procedure TfMain.FormShow(Sender: TObject);
begin
  edtPath.Directory  := fConfig.OutputPath;
  edtPath.Text       := fConfig.OutputPath;
  edtPath.InitialDir := fConfig.OutputPath;
end;

procedure TfMain.GerarHFT(const StartPath: string);
begin
  mmLog.Clear;

  if rgTipoPagina.ItemIndex = 0 then
    fFindFiles.FileMask := '*.tif'
  else
    fFindFiles.FileMask := '*-' + rgTipoPagina.Items[rgTipoPagina.ItemIndex] + '.tif';

  fFindFiles.StartPath := StartPath;//Dir de destino
  fFindFiles.Active := true;
end;

procedure TfMain.LogMessage(const Msg: string);
begin
  mmLog.Lines.Insert(0, Msg);
end;

procedure TfMain.OnFile(Sender: TObject; const FileName: string);
{
  Observação:
  Por padrão, os arquivos de tarefas são armazenados em %Userprofile%\Local Settings\Application Data\ABBYY\HotFolder\9.00 (%Userprofile%\AppData\Local\ABBYY\HotFolder\9.00 para Microsoft Windows Vista)
  Para que sejam "Importados" copie-os para a esta pasta de tarefas.
  A pasta só é lida quando o Hot Folder inicia.
}
var
  Stream: TFileStream;
  JobName, hftName: string;
  SR: TSearchRec;
  dir_job, Dir: String;
  lista: TList<String>;
  I: integer;
begin
  fFindFiles.ListaArquivo := TList<String>.Create;
  lista := TList<String>.Create;

  //fFindFiles.NextDirectory;

  fJob.Path := ExtractFilePath(FileName);
  JobName := ExtractFileName(FileName);
  JobName := ChangeFileExt(JobName, '');
  fJob.JobName := Copy(JobName, 1, 255);
  if (Length(fJob.Path) > 255) then
  begin
    LogMessage(Format('NÃO pode processar path > 255: %s', [fJob.Path]));
    Exit;
  end;

  hftName := fFindFiles.StartPath + JobName + '.hft';

  Stream := TFileStream.Create(hftName, fmCreate);
  try
    fJob.SaveToStream(Stream);
  finally
    Stream.Free;
  end;

  LogMessage(Format('Processado: %s -> %s', [FileName, hftName]));
end;

end.

Código Delphi [-]
uses Generics.Collections;

type
  TFileFoundEvent = procedure(Sender: TObject; const FileName: string) of object;
  TDirectoryFoundEvent = procedure(Sender: TObject; const FileName: string; var Aceitar: Boolean) of object;

  TFileFinder = class
  private
    fRecursive: Boolean;
    fOnFile: TFileFoundEvent;
    fFileMask: string;
    fOnDirectory: TDirectoryFoundEvent;
    fStartPath: string;
    fActive: Boolean;
    fNextDir: Boolean;
    fOnDir: string;
    fLista: TList<String>;
  private
    procedure SetActive(const Value: Boolean);
    procedure SetStartPath(const Value: string);
  private
    function AceitarDirectory(const FileName: string): Boolean;
    procedure AceitarFile(const FileName: string);
    procedure Start;
  public
    constructor Create;
    procedure NextDirectory;
    property Active: Boolean read fActive write SetActive;
    property StartPath: string read fStartPath write SetStartPath;
    property Recursive: Boolean read fRecursive write fRecursive;
    property FileMask: string read fFileMask write fFileMask;
    property OnDirectory: TDirectoryFoundEvent read fOnDirectory
      write fOnDirectory;
    property OnFile: TFileFoundEvent read fOnFile write fOnFile;
    property OnDir: string read fOnDir write fOnDir;
    property ListaArquivo: TList<String> read fLista write fLista;
  end;

implementation

uses SysUtils;

{ TFileFinder }

function TFileFinder.AceitarDirectory(const FileName: string): Boolean;
begin
  Result := Active;
  if Result and Assigned(OnDirectory) then
    OnDirectory(self, FileName, Result);
end;

procedure TFileFinder.AceitarFile(const FileName: string);
begin
  if Active and Assigned(OnFile) then
    OnFile(self, FileName);
end;

constructor TFileFinder.Create;
begin
  inherited Create;
  Recursive := true;
end;

procedure TFileFinder.NextDirectory;
begin
  fNextDir := true;
end;

procedure TFileFinder.SetActive(const Value: Boolean);
begin
  if fActive <> Value then
  begin
    fActive := Value and DirectoryExists(StartPath);
    if fActive then
      Start;
  end;
end;

procedure TFileFinder.SetStartPath(const Value: string);
begin
  fStartPath := IncludeTrailingPathDelimiter(Value);
end;

procedure TFileFinder.Start;
  procedure PathFound(const Path: string);
  var
    Dir: string;
    Mask: string;
    SR: TSearchRec;
    List: TList<String>;
    I,c: Integer;
  begin
    List := TList<String>.Create();
    fLista := TList<String>.Create;
    Dir := IncludeTrailingPathDelimiter(Path);
    if not AceitarDirectory(Dir) then
      Exit;

    // Procura os arquivos
    Mask := Dir + FileMask;
    if Active and (FindFirst(Mask, faAnyFile - faDirectory, SR) = 0) then
      try
        fNextDir := false;
        repeat
          List.AddRange([SR.Name]);
          List.Sort;
          for I := 0 to List.Count - 1 do
          begin
            AceitarFile(Dir + List[i]{SR.Name});
          end;
        until (FindNext(SR) <> 0) or (not Active) or fNextDir;

      finally
        FindClose(SR);
      end;

    // Percorre a arvore de diretórios
    Mask := Dir + '*.*';
    OnDir := Mask;
    if Active and Recursive and (FindFirst(Mask, faDirectory, SR) = 0) then
      try
        repeat
          if (SR.Name <> '.') and (SR.Name <> '..') then
            PathFound(Dir + SR.Name);
        until (FindNext(SR) <> 0) or (not Active);
      finally
        FindClose(SR);
      end;
  end;

begin
  PathFound(fStartPath);
  Active := false;
end;

end.