procedure CopyDirectory(Origen, Desti : string);
var
    Files : integer;

    FOrigen, FDesti : string;

    ok     : boolean;

    Search : TSearchRec;
begin
     Files := FindFirst(Origen + "\*.*", faAnyFile, Search);

     while Files = 0 do
 begin
 if Search.Attr <> faDirectory then
 begin
                 FOrigen := Origen + "\" + Search.Name;

                 FDesti := Desti + "\" + Search.Name;

                 ok := CopyFile(PChar(FOrigen),PChar(FDesti),false);

                 if not ok then ShowMessage("No se pudo copiar el fichero: "+

                                                               Search.Name);

            end
 else
 begin
 if (Search.Name <> ".") and (Search.Name <> "..") then
 begin
                       ok := CreateDir(Desti + "\" + Search.Name);

                       if not ok then ShowMessage("No se pudo crear el directorio: "+

                                                                         Search.Name)

                       else CopiaDirectori(Origen+"\"+Search.Name,Desti+"\"+Search.Name);

                  end;

            end;

           Files := FindNext(Search);

      end;

     FindClose(Search);
end;

برگرفته شده از سایت دنیای برنامه نویسی دلفی(http://mt85.blogfa.com)