Fórum rotina para copiar pastas #354734

Olá pessoal!!!!
criei uma rotina em meu sistema para copiar uma pasta no computador e gravar num pen drive, na verdade a arigem do arquivo e o destino são configuravéis,,,,qdo configuro para copiar do C:\ da maquina e gravar em outra pasta no C:\ a operação é realizada bem rapidinho, mas se eu copiar do C:\ e gravar num pendrive demora muito, mas muito mesmo a ponto de ficar inviavél
bom abaixo vai a rotina q criei para fazer a copia da pasta, se alguém tiver uma dica do q posso fazer para agilizar a copia eu agradeço!!!

Obrigado!!!!


procedure TFrmCopiarTabela.Button1Click(Sender: TObject);
var
SR: TSearchRec;
I, Y: integer;
Origem, Destino, EditOrigen, EditDestino, Str_Data: string;
begin

Str_Data:= FormatDateTime(´dd/mm/yy´,Date);

Y := pos(´/´,Str_Data);
while Y <> 0 do begin
delete(Str_Data,Y,1);
Y := pos(´/´,Str_Data);
end;
if modulodados.BaseDados = 1 then
EditDestino:= edit2.Text +´/Tabelas´+ Str_Data
else
EditDestino:= edit2.Text +´/TabelasV´+ Str_Data;

If not CreateDir(EditDestino) Then
begin
ShowMessage(´Ocorreu um erro ao criar a pasta no diretório de destino, é possível que já haja um backup no diretório de destino com a data de hoje!´);
abort;
end;
label1.Visible:= true;
label1.Caption:= ´Copiando...´;
I := FindFirst(edit1.text+ ´\*.*´, faAnyFile, SR);
while I = 0 do
begin
if (SR.Attr and faDirectory) <> faDirectory then
begin
Origem := edit1.text +´\´ + SR.Name;
Destino := EditDestino+´\´ + SR.Name;
if not CopyFile(PChar(Origem), PChar(Destino), true) then
begin
ShowMessage(´Erro ao copiar ´ + Origem + ´ para ´ + Destino);
abort;
end;
end;
I := FindNext(SR);
end;
If not CreateDir(EditDestino+´\Net´) Then
begin
ShowMessage(´Ocorreu um erro ao criar a pasta Net!´);
abort;
end;
label1.Caption:= ´Arquivo copiado com sucesso!´;
end;