JAI_ME,
Cita:
Empezado por JAI_ME
Cuando subo un archivo no hay problema, el problema viene cuando intento subir muchos archivos casi que a la ves.
Hey leído y una posible solución seria crear varios hilos de ejecución. pero a que se refieren con hilos, crear en tiempo de ejecución varios TidFTP ???
|
Revisa este código:
Código Delphi
[-]
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, ComCtrls, idantifreeze, idftp, IdAntiFreezeBase,
IdTCPClient, IdComponent;
type
TForm1 = class(TForm)
Label1: TLabel;
Label4: TLabel;
txtHost: TEdit;
txtPort: TEdit;
Label5: TLabel;
Label6: TLabel;
txtUsername: TEdit;
txtPassword: TEdit;
Label7: TLabel;
txtFolder: TEdit;
Label8: TLabel;
ListBox1: TListBox;
Memo1: TMemo;
chkMode: TCheckBox;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
BitBtn3: TBitBtn;
BitBtn4: TBitBtn;
BitBtn5: TBitBtn;
ProgressBar1: TProgressBar;
procedure FormCreate(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure BitBtn3Click(Sender: TObject);
procedure BitBtn4Click(Sender: TObject);
procedure BitBtn5Click(Sender: TObject);
procedure FTPWork(Sender: TObject; AWorkMode: TWorkMode;const AWorkCount: Integer);
procedure ThreadDone(Sender: TObject);
private
public
end;
var
Form1: TForm1;
FtpMax : Integer;
ThreadsRunning : Integer;
implementation
{$R *.dfm}
type
TUploaderThread=class(TThread)
private
FFileName : String;
FServer : String;
FPort : Integer;
FPassive : Boolean;
FUser : String;
FPassword : String;
FDestinationDir : String;
FE : Exception;
FSize : Integer;
procedure HandleException;
procedure FinishedUpload;
procedure ProgressFTP;
protected
procedure execute; override;
public
constructor Create(AServer:string; APort:integer; APassive:boolean; AUser, APassword, ADestinationDir, AFileName:string);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
with TIdAntiFreeze.Create(self) do Active:=true;
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
var
openDialog : TOpenDialog;
i : Integer;
begin
openDialog := TOpenDialog.Create(self);
openDialog.InitialDir := GetCurrentDir;
openDialog.Options := [ofFileMustExist, ofAllowMultiSelect];
openDialog.Filter := 'Archivos a FTP Upload|*.*';
openDialog.FilterIndex := 1;
if openDialog.Execute then
begin
for i := 0 to openDialog.Files.Count-1 do
listbox1.items.add(openDialog.Files[i]);
end;
end;
procedure TForm1.BitBtn2Click(Sender: TObject);
begin
if listbox1.ItemIndex = -1 then
exit
else
listbox1.DeleteSelected;
end;
procedure TForm1.BitBtn3Click(Sender: TObject);
var
i : Integer;
F: File of byte;
begin
if (txtUsername.Text = '') or (txtPassword.Text = '') or (txtHost.Text = '') then
begin
MessageDlg('Error de Parámetros de Comunicación', mtinformation, [mbok], 0);
Exit;
end;
if listbox1.items.count = 0 then
begin
MessageDlg('Lista de FTP Upload Esta Vacía', mtinformation, [mbok], 0);
Exit;
end;
memo1.Clear;
with TIdFtp.Create(self) do
try
OnWork := FTPWork;
Username := txtUsername.text;
Password := txtPassword.text;
Passive := chkMode.checked;
Host := txtHost.text;
Port := StrToIntDef(txtPort.text, 21);
Connect;
if txtFolder.text <> '' then
ChangeDir(txtFolder.text);
for i := 0 to listbox1.items.count-1 do
begin
try
Application.ProcessMessages;
AssignFile(F, listbox1.Items[i]);
Reset(F);
ProgressBar1.Max := FileSize(F) div 1024;
CloseFile(F);
memo1.lines.add('Iniciando FTP Upload: ' + listbox1.Items[i]);
Put(listbox1.Items[i], ExtractFileName(listbox1.Items[i]),False);
memo1.lines.add('Finalizando FTP Upload: ' + listbox1.Items[i]);
except
on e:exception do
begin
memo1.lines.add('Error en FTP Upload: ' + listbox1.Items[i-1]+': '+e.message);
MessageDlg('Proceso de FTP Upload Finalizo con Error', mtinformation, [mbok], 0);
exit;
end;
end;
end;
MessageDlg('Proceso de FTP Upload Finalizado', mtinformation, [mbok], 0);
finally
free;
end;
end;
procedure TForm1.BitBtn4Click(Sender: TObject);
var
i : integer;
begin
if (txtUsername.text = '') or (txtPassword.text = '') or (txtHost.text = '') then
begin
MessageDlg('Error de Parámetros de Comunicación', mtinformation, [mbok], 0);
Exit;
end;
if listbox1.items.count = 0 then
begin
MessageDlg('Lista de FTP Upload Esta Vacía', mtinformation, [mbok], 0);
exit;
end;
MessageDlg('Envio de Múltiples Archivos Puede Fallar si el Servidor FTP No lo Permite', mtinformation, [mbok], 0);
memo1.Clear;
FtpMax := 0;
ThreadsRunning := 0;
for i := 0 to listbox1.items.count-1 do
begin
memo1.lines.add('Iniciando FTP Upload: ' + listbox1.Items[i]);
TUploaderThread.Create(txtHost.text, strtointdef(txtPort.text, 21), chkMode.checked, txtUsername.text, txtPassword.Text, txtFolder.Text, listbox1.items[i]);
end;
end;
procedure TForm1.FTPWork( Sender: TObject; AWorkMode: TWorkMode;const AWorkCount: Integer);
begin
ProgressBar1.Position := AWorkCount div 1024;
end;
constructor TUploaderThread.Create(AServer:string; APort:integer; APassive:boolean; AUser, APassword, ADestinationDir, AFileName: string);
begin
FServer := AServer;
FPort := APort;
FPassive := APassive;
FUser := AUser;
FPassword := APassword;
FDestinationDir := ADestinationDir;
FFileName := AFileName;
OnTerminate := Form1.ThreadDone;
FreeOnTerminate := True;
inherited create(false);
end;
procedure TUploaderThread.ProgressFTP;
begin
form1.ProgressBar1.Max := FtpMax;
end;
procedure TUploaderThread.execute;
var
F: File of byte;
begin
try
Inc(ThreadsRunning);
with TIdFtp.Create(nil) do
try
OnWork := Form1.FTPWork;
Username := FUser;
Password := FPassword;
Passive := FPassive;
Host := FServer;
Port := FPort;
Connect;
if FDestinationDir <> '' then
ChangeDir(FDestinationDir);
AssignFile(F, FFileName);
Reset(F);
FSize := FileSize(F) div 1024;
FtpMax := FtpMax + FSize;
Synchronize(ProgressFTP);
CloseFile(F);
Put(FFileName, ExtractFileName(FFileName),False);
Synchronize(FinishedUpload);
finally
free;
end;
except
on e:exception do
Synchronize(HandleException);
end;
end;
procedure TUploaderThread.FinishedUpload;
begin
form1.memo1.lines.add('Finalizando FTP Upload: ' + FFilename);
form1.ProgressBar1.Position := FTPMax;
end;
procedure TUploaderThread.HandleException;
begin
form1.memo1.lines.add('Error en FTP Uploading en ' + FFilename + ': ' + fe.Message);
end;
procedure TForm1.BitBtn5Click(Sender: TObject);
begin
with form1 do
begin
txtUsername.Text := '';
txtPassword.Text := '';
txtFolder.Text := '';
Listbox1.Clear;
Memo1.Clear;
Progressbar1.Position := 0;
end;
end;
procedure TForm1.ThreadDone(Sender: TObject);
begin
Dec(ThreadsRunning);
if ThreadsRunning = 0 then
begin
MessageDlg('Proceso de FTP Upload Finalizado', mtinformation, [mbok], 0);
end;
end;
end.
El código anterior envía múltiples archivos vía FTP usando dos métodos:
1- Enviando múltiples archivos de forma individual (Uno a Uno).
2- Enviando múltiples archivos de forma simultanea por medio de Threads.
Nota:
1- Los archivos se pueden seleccionar por medio de un TOpenDialog que permite selección multiple.
2- La cantidad de Bytes enviados al servidor FTP se controla por medio de un TProgressBar.
Cita:
Empezado por JAI_ME
como se dan cuenta envío el mismo archivo al servidor y hay veces que envía mas de 1000 archivos sin sacar el error
|
No es conveniente crear 1000 Threads, prueba primero la forma individual y luego la simultanea a ver cual se puede adaptar mejor a tu proyecto. El método 1 es el más recomendable para FTP masivos.
La aplicación fue realizada en Delphi 7 usando el Componente FTP de Indy 9.
La aplicación esta implementada en el siguiente link:
FTPUpload_MultiFiles.rar
Espero sea útil
Nelson.