Crear Hilos de Ejecución con TIdFTP

[[movorack]]

Hola JAI_ME

Para el tema de los hilos de ejecución, te recomiendo leas un poco al respecto.

- Los Hilos de Ejecución
- Threading in Delphi

Eso te dará algunas ideas de como implementar lo que necesitas sobre los hilos de ejecución o te aclarará si necesariamente los requieres para solucionar tus problemas.

[Casimiro Noteví]

De todas formas, si quieres hacerlo con lo que tienes ahora, puedes controlar al llamar a esa función si ya está enviando algo, en ese caso esperas.
Puedes meter todos los envíos en una cola, una simple lista, y un timer que vaya comprobando si ya acabó de enviar, en cuanto está libre entonces envía el siguiente de la cola, y hasta que se terminen todos.

[JAI_ME]

Empezado por Casimiro Notevi

De todas formas, si quieres hacerlo con lo que tienes ahora, puedes controlar al llamar a esa función si ya está enviando algo, en ese caso esperas.
Puedes meter todos los envíos en una cola, una simple lista, y un timer que vaya comprobando si ya acabó de enviar, en cuanto está libre entonces envía el siguiente de la cola, y hasta que se terminen todos.

Ya estoy estudiando el caso de los hilos, pero es interesante lo que comentas, a manera de ejemplo estoy haciendo lo siguiente.

En un boton tengo el siguiente código donde hago la llamada al procedimiento que envia al servidor

procedure TForm1.Button1Click(Sender: TObject);
begin
for i := 1 to 10000 do begin
SubirArchivo('C:\mi_archivo.jpg');
Caption := inttostr(i);
end;
end;

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, en este ejemplo como implemento lo que me comentas.

PD. la función subirArchivo tiene el código que expuse al principio.

[Casimiro Noteví]

No, así no, hazlo con un Timer, le pones que se ejecute cada 1 segundo, por ejemplo, y en su evento 'execute' haces la llamada a subirarchivo con el que toque de la lista que tengas.
A ver si encuentro un ejemplo...

[[nlsgarcia]]

JAI_ME,

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
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  FtpMax : Integer;
  ThreadsRunning : Integer;

implementation

{$R *.dfm}

// Clase Threads para envío múltiple de archivos
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;

// Permite que la aplicación responda a eventos cuando esta haciendo el FTP
procedure TForm1.FormCreate(Sender: TObject);
begin
   with TIdAntiFreeze.Create(self) do Active:=true;
end;

// Selección múltiple de archivos a enviar
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;

// Elimina archivos de lista de envío FTP
procedure TForm1.BitBtn2Click(Sender: TObject);
begin
  if listbox1.ItemIndex = -1 then
    exit
  else
    listbox1.DeleteSelected;
end;

// Envío de Archivos Simple (Uno a uno)
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;

// Envío de Archivos Multiples (Todos Simultaneamente)
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;

// Actualiza posición FtpMax (Cantidad Total de Bytes enviados) en TUploaderThread
procedure TForm1.FTPWork( Sender: TObject; AWorkMode: TWorkMode;const AWorkCount: Integer);
begin
   ProgressBar1.Position := AWorkCount div 1024;
end;

// Create el Objeto TUploaderThread por cada archivo a enviar
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;

// Actualiza posición FtpMax (Cantidad Total de Bytes a Enviar)
procedure TUploaderThread.ProgressFTP;
begin
   form1.ProgressBar1.Max := FtpMax;
end;

// Envío de Archivos Multiples con TUploaderThread
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;

// Fin de envío con TUploaderThread
procedure TUploaderThread.FinishedUpload;
begin
   form1.memo1.lines.add('Finalizando FTP Upload: ' + FFilename);
   form1.ProgressBar1.Position := FTPMax;
end;

// Error de envío con TUploaderThread
procedure TUploaderThread.HandleException;
begin
   form1.memo1.lines.add('Error en FTP Uploading en ' + FFilename + ': ' + fe.Message);
end;

// Reset opciones de envío en form1
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;

// Envía un mensaje al finalizar todos los Threads activos
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.

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.

[Casimiro Noteví]

Está muy bien esa solución.

Aunque para estas cosas no sé yo si vale la pena, me explico: si tiene que subir 1000 archivos entonces tardará según el ancho de banda que tenga. Si usa hilos lo único que se consigue es que en lugar de subir un archivo a, por ejemplo, 1 mega, subirán 2 a medio mega, 4 a un cuarto de mega, etc. o sea, que no se reducirá el tiempo. Es por lo que personalmente prefiero subir uno a uno, ya que el tiempo para subirlos no va a mejorar, así que no lo encuentro muy necesario.
Es sólo una preferencia personal.

Tengo algunos programitas que hacen eso, por ejemplo, uno de ellos sube imágenes casi diariamente (por FTP) a una web, son imágenes pequeñas (10 a 50 Kb), aunque son muchas (alrededor de 20 ó 30 mil) y lo hace una a una. Por supuesto, envía una cuando ha acabado con otra, no se intenta enviar todas al mismo tiempo, que es el problema que no ha controlado JAI_ME.

De todas formas, la solución propuesta nlsgarcia es excelente.

[Broskil Giovann]

Hola a todos,

gracias nslgarcia por el código propuesto.
Tengo un problema con el código que he utilizado yo para enviar mediante un TidSMTP un correo electrónico.
El problema me aparece en mi código pero tambien en el proyecto que he descargado en el link que nos indicas.

En estas dos funciones, al acceder al Formulario para añadir las lineas en el Memo1, me devuelve un "Access Violation".

Código Delphi [-]
// Fin de envío con TUploaderThread
procedure TUploaderThread.FinishedUpload;
begin
   form1.memo1.lines.add('Finalizando FTP Upload: ' + FFilename);
   form1.ProgressBar1.Position := FTPMax;
end;

// Error de envío con TUploaderThread
procedure TUploaderThread.HandleException;
begin
   form1.memo1.lines.add('Error en FTP Uploading en ' + FFilename + ': ' + fe.Message);
end;

¿Alguna idea?