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; 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);
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;
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;
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;
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]);
end;
until (FindNext(SR) <> 0) or (not Active) or fNextDir;
finally
FindClose(SR);
end;
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.