Carpeta y carpeta adentro
 

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.

Código Delphi [-]
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;

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

Código Delphi [-]
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.

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