Carpeta y carpeta adentro

[Paulao]

Quiero crear una serie de carpetas una a dentro de otra y despues mover un archivo para esta carpeta. La regla es esta:
La primera regla es crear una carpeta con los 4 primer substring(Copy(String,1,4)). Bueno, despues, viene otra carpeta que es la posicion 5 y 6 y despues la posicion 7 y 8. Quando terminar todo, entonces si mueve el archivo para esta carpeta, ademas todos los archivos. Mi programa cria las carpetas, pero la repete las 3 ultimas y pone un archivo solo dentro della e los demas archivos pone en la primera carpeta. Mi codigo se quedo mui procedural y fue haciendo, haciendo y se quedo mui feo, pero feo mismo. Abajo mi codigo.

procedure TForm1.InverteArquivo(Origem, Destino: String);
var
SR: TSearchRec;
DDir,SDir, Dir: String;
I: Integer;
NmDir, NmExt, diret:string;
posicao: boolean;
begin
SDir := IncludeTrailingPathDelimiter(Origem);
DDir := IncludeTrailingPathDelimiter(Destino);

if not DirectoryExists(DDir + 'TIF') then
ForceDirectories(DDir + 'TIF');
if not DirectoryExists(DDir + 'PDF') then
ForceDirectories(DDir + 'PDF');
if not DirectoryExists(DDir + 'TXT') then
ForceDirectories(DDir + 'TXT');

I := FindFirst(SDir + '*.*', faAnyFile, SR);
while I = 0 do
begin
if (SR.Name <> '.') and (SR.Name <> '..') and (SR.Attr <> faDirectory)then
begin
NmDir := UpperCase(Copy(ExtractFileExt(SDir + SR.Name),2,3));
DDir := DDir + IncludeTrailingPathDelimiter(NmDir);

if NmDir = 'TIF' then
begin
//DDir := DDir + 'TIF';
if not DirectoryExists(Dir + Copy(SR.Name,1,4)) then
begin
ForceDirectories(DDir + Copy(SR.Name,1,4));
DDir := DDir + IncludeTrailingPathDelimiter(Copy(SR.Name,1,4));
end;
if not DirectoryExists(DDir + Copy(SR.Name,5,2)) then
begin
ForceDirectories(DDir + Copy(SR.Name,5,2));
DDir := DDir + IncludeTrailingPathDelimiter(Copy(SR.Name,5,2));
end;
if not DirectoryExists(DDir + Copy(SR.Name,7,2)) then
begin
ForceDirectories(DDir + Copy(SR.Name,7,2));
DDir := DDir + IncludeTrailingPathDelimiter(Copy(SR.Name,7,2));
end;

if not DirectoryExists(DDir + NomePasta(SR.Name,2)) then
begin
ForceDirectories(DDir + NomePasta(SR.Name,2));
DDir := DDir + IncludeTrailingPathDelimiter(NomePasta(SR.Name,2));
end;
MoveFile(PChar(SDir + SR.Name),PChar(DDir + SR.Name));
DDir := DDir + IncludeTrailingPathDelimiter(NmDir);
end

else

if NmDir = 'PDF'then
begin
if not DirectoryExists(Dir + Copy(SR.Name,1,4)) then
begin
ForceDirectories(DDir + Copy(SR.Name,1,4));
DDir := DDir + IncludeTrailingPathDelimiter(Copy(SR.Name,1,4));
end;
if not DirectoryExists(DDir + Copy(SR.Name,5,2)) then
begin
ForceDirectories(DDir + Copy(SR.Name,5,2));
DDir := DDir + IncludeTrailingPathDelimiter(Copy(SR.Name,5,2));
end;
if not DirectoryExists(DDir + Copy(SR.Name,7,2)) then
begin
ForceDirectories(DDir + Copy(SR.Name,7,2));
DDir := DDir + IncludeTrailingPathDelimiter(Copy(SR.Name,7,2));
end;

if not DirectoryExists(DDir + NomePasta(SR.Name,2)) then
begin
ForceDirectories(DDir + NomePasta(SR.Name,2));
DDir := DDir + IncludeTrailingPathDelimiter(NomePasta(SR.Name,2));
end;
MoveFile(PChar(SDir + SR.Name),PChar(DDir + SR.Name));
DDir := DDir + IncludeTrailingPathDelimiter(NmDir);
end
else
if NmDir = 'TXT' then
begin
if not DirectoryExists(Dir + Copy(SR.Name,1,4)) then
begin
ForceDirectories(DDir + Copy(SR.Name,1,4));
DDir := DDir + IncludeTrailingPathDelimiter(Copy(SR.Name,1,4));
end;
if not DirectoryExists(DDir + Copy(SR.Name,5,2)) then
begin
ForceDirectories(DDir + Copy(SR.Name,5,2));
DDir := DDir + IncludeTrailingPathDelimiter(Copy(SR.Name,5,2));
end;
if not DirectoryExists(DDir + Copy(SR.Name,7,2)) then
begin
ForceDirectories(DDir + Copy(SR.Name,7,2));
DDir := DDir + IncludeTrailingPathDelimiter(Copy(SR.Name,7,2));
end;

if not DirectoryExists(DDir + NomePasta(SR.Name,2)) then
begin
ForceDirectories(DDir + NomePasta(SR.Name,2));
DDir := DDir + IncludeTrailingPathDelimiter(NomePasta(SR.Name,2));
end;
MoveFile(PChar(SDir + SR.Name),PChar(DDir + SR.Name));
DDir := DDir + IncludeTrailingPathDelimiter(NmDir);
end;

end;

//DDir := IncludeTrailingPathDelimiter(Destino);
I := FindNext(SR);
end;
FindClose(SR);

I := FindFirst(SDir + '*', faDirectory, SR);
while I =0 do
begin
if (SR.Attr = faDirectory) and (SR.Name <> '.') and (SR.Name <> '..') then
InverteArquivo(SDir + SR.Name,DDir);
I := FindNext(SR);
end;
end;

[ecfisa]

Hola Paulao.
Quiero crear una serie de carpetas una a dentro de otra y despues mover un archivo para esta carpeta. La regla es esta:
La primera regla es crear una carpeta con los 4 primer substring(Copy(String,1,4)). Bueno, despues, viene otra carpeta que es la posicion 5 y 6 y despues la posicion 7 y 8. Quando terminar todo, entonces si mueve el archivo para esta carpeta, ademas todos los archivos.

Por lo que pude entender, este procedimiento hace lo que estas buscando:

procedure PasarArchivos(Origen, Destino: string);
var
SR: TSearchRec;
Nombre: string;
begin
Origen:= IncludeTrailingPathDelimiter(Origen);
Destino:= IncludeTrailingPathDelimiter(Destino);
if FindFirst(Origen+'*.*',faArchive,SR) = 0 then
begin
Nombre:= Copy(ExtractFileName(SR.Name),1,
Length(ExtractFileName(SR.Name))-
Length(ExtractFileExt(SR.Name)));
ForceDirectories(Destino+Copy(Nombre,1,4));
ForceDirectories(Destino+Copy(Nombre,1,4)+'\'+Copy(Nombre,5,2));
ForceDirectories(Destino+Copy(Nombre,1,4)+'\'+Copy(Nombre,5,2)+'\'+
Copy(Nombre,7,2));
repeat
CopyFile(PChar(Origen+SR.Name),PChar(Destino+Copy(Nombre,1,4)+'\'+
Copy(Nombre,5,2)+'\'+Copy(Nombre,7,2)+'\'+SR.Name),False);
until FindNext(SR) <> 0;
end;
end;

Toma el primer nombre de archivo de la carpeta origen. De donde extrae las cadenas para crear la carpeta, la sub-carpeta y la sub-sub-carpeta. Por último copia los archivos de la carpeta orígen allí.

Nota: El código no realiza ninguna comprobación. (Como por ejemplo que haya un nombre de archivo con menos de 8 caracteres).


Saludos.

[Paulao]

Gracias, ecfisa. Hizo algunos ajuste y funcionó. Listo.