Fórum Minha consulta repete várias vezes #404361

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.

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.