Crear Hilos de Ejecución con TIdFTP

[JAI_ME]

Buenas tardes, he subido un archivo por ftp con los componentes indy usando el siguiente código

FTP := TIdFTP.Create( nil );
FTP.OnWork := FTPWork;

FTP.Username := miusuario;
FTP.Password := miclave;
FTP.Host := localhost;
try
FTP.Connect;
except
raise Exception.Create( 'No se ha podido conectar con el servidor ' + FTP.Host );
end;
FTP.Put( sArchivo, ExtractFileName( sArchivo ), False );
FTP.Disconnect;
FTP.Free;

Cuando subo un archivo no hay problema, el problema viene cuando intento subir muchos archivos casi que a la ves, me saca el siguiente error

raised exception class EIDSocketError with message 'Socket Error # 10048 Address already in use.'
Process stopped. Use Step or Run to continue.

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 ???

Como logra hacer esto o solucionar este problema muchas gracias de ante mano.

[Casimiro Notevi]

Recuerda poner los tags al código fuente, ejemplo:



Gracias

[JAI_ME]

Gracias casimiro, lo tendré en cuenta para la próxima.

[[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 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.

[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 Notevi]

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 Notevi]

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?

[[nlsgarcia]]

Broskil Giovann,

Empezado por Broskil Giovann

...Tengo un problema con el código que he utilizado...para enviar mediante un TidSMTP un correo electrónico...pero también en el proyecto que he descargado en el link que nos indicas...

Te comento:

1- El código señalado en el Msg #8 funciona correctamente en Delphi 7 usando el Componente FTP de Indy 9 bajo Windows 7 Professional x32.

2-El código señalado es para enviar archivos a un servidor FTP, no para el envío de emails.

Pregunto:

1- ¿Que versión de Windows, Delphi y Indy utilizas?.

2- ¿Podrías publicar el error que te aparece en el código del Msg #8?.

3- ¿Si usas la opción de Envío de Archivos Simple (Uno a uno) funciona?.

Empezado por Broskil Giovann

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

4- ¿El formulario en cuestión esta instanciado?.

Espero sea útil

Nelson.

[Broskil Giovann]

Muchas gracias Nelson,

contesto a tus comentarios...

1- El código señalado en el Msg #8 funciona correctamente en Delphi 7 usando el Componente FTP de Indy 9 bajo Windows 7 Professional x32.

2-El código señalado es para enviar archivos a un servidor FTP, no para el envío de emails.

Pregunto:

1- ¿Que versión de Windows, Delphi y Indy utilizas?.

* Windows 7 Professional
* Delphi 7
* Indy 10.5.5

2- ¿Podrías publicar el error que te aparece en el código del Msg #8?.

No da error. Fue un error mio.

3- ¿Si usas la opción de Envío de Archivos Simple (Uno a uno) funciona?.

Funcionan los dos.

4- ¿El formulario en cuestión esta instanciado?.

Te adjunto todo el codigo para que lo veas:

Código Delphi [-]
unit U_PS025;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls, DBCtrls, Mask, MesControls,
  Dades_Mensaje, Buttons, jpeg, MesStrings, MesDates, DateUtils,
  mesBaseDades, Dades_Finestres, ComCtrls, IdEmailAddress,
  IdMessageParts, IdAttachmentFile, MyAccess, IdSMTP, IdFTP, IdFTPCommon,
  IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdExplicitTLSClientServerBase, AdvMetroButton, GIFImg, IdAntiFreezeBase,
  IdAntiFreeze, IdMessageClient, IdSMTPBase,
  IdIOHandler, IdIOHandlerSocket, IdIOHandlerStack,
  IdSSL, IdSSLOpenSSL, frxExportPDF, Dades_Aplicacio,
  IdReplySMTP, IdSSLOpenSSLHeaders,
  Registry, ShellAPI, IdHTTP, IdMessage;

type
  TF_PS025 = class(TForm)
    GBCorreo: TGroupBox;
    Label26: TLabel;
    LReferencias: TLabel;
    EAsunto: TEdit;
    Label1: TLabel;
    LUsuario: TLabel;
    ECuerpo: TMemo;
    GBEnviando: TGroupBox;
    CBSolicitarConfirmacion: TCheckBox;
    GroupBox1: TGroupBox;
    Label3: TLabel;
    EPassword: TEdit;
    GroupBox2: TGroupBox;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    GroupBox3: TGroupBox;
    LlistaAdjunts: TListBox;
    GBFax: TGroupBox;
    Label7: TLabel;
    EFax: TEdit;
    Button2: TButton;
    GBCorreoElectronico: TGroupBox;
    Label2: TLabel;
    EDestinatario: TEdit;
    Button1: TButton;
    CBTodos: TCheckBox;
    LCorreoElectronico: TLabel;
    LFax: TLabel;
    Label8: TLabel;
    LFtp: TLabel;
    GBFtp: TGroupBox;
    Label9: TLabel;
    ENombre: TEdit;
    EEmpresa: TEdit;
    Button3: TButton;
    Label10: TLabel;
    LEmpresa: TLabel;
    AdvMetroButton3: TAdvMetroButton;
    AdvMetroButton1: TAdvMetroButton;
    Memo1: TMemo;
    procedure FormShow(Sender: TObject);
    procedure EAsuntoKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure EDestinatarioKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Label4Click(Sender: TObject);
    procedure Label6Click(Sender: TObject);
    procedure Label5Click(Sender: TObject);
    procedure LlistaAdjuntsDblClick(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure LCorreoElectronicoClick(Sender: TObject);
    procedure LFaxClick(Sender: TObject);
    procedure Label8Click(Sender: TObject);
    procedure LFtpClick(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure AdvMetroButton3Click(Sender: TObject);
    procedure AdvMetroButton1Click(Sender: TObject);
    procedure ThreadDone(Sender: TObject);
  private
    i: SmallInt;
    Mail, Fax, Ftp: Boolean;
    { Private declarations }
    procedure FinestraDireccions;
    procedure FinestraFax;
    procedure FinestraDocumento;
    Procedure FinestraEmpresa;
  public
    IdEmpleado: Integer;
    Todos, Borrar, SolicitarConfirmacion: Boolean;
    Asunto, Destinatario, Cuerpo, DocumentoAdjunto, Password: String;
    { Public declarations }
    Procedure EditAVariable;
  end;

var
  F_PS025: TF_PS025;
  compEnvioEmail : TIdSMTP;
  PTIdFtp : TIdFtp;
  compIoHandler: TIdSSLIOHandlerSocketOpenSSL;

implementation

{$R *.dfm}

// Clase Threads
type
  TThreadMail = class(TThread)
  private
    TServidorUsuario : String;
    TMailUsuario : String;
    TPassUsuario : String;
    TPuertoUsuario : Integer;
    TAsunto: String;
    TMensaje: TStringList;
    TAutenticacion: Boolean;
    TEmisor: String;
    TNombreEmisor: String;
    TDestinatario: String;
    TCc: String;
    TAdjunto: String;
    TSolicitarConfirmacion: Boolean;
    TFinalitzar: Boolean;
    TBorrar: Boolean;
    TListaAdjuntos: TStringList;
    TEx : Exception;
    { Private declarations }
    procedure EnvioFinalizado;
    procedure HandleException;
    procedure InicioEnvio;
  protected
    procedure execute; override;
  public
    Constructor Create(
      ServidorUsuario, MailUsuario, PassUsuario : String;
      PuertoUsuario : Integer;
      Asunto: String;
      Mensaje: TStringList;
      Autenticacion, Borrar, SolicitarConfirmacion: Boolean;
      Emisor, NombreEmisor: String;
      MailsDestinatarios: String;
      Cc, Adjunto: String; ListaAdjuntos: TStringList);
  end;

procedure TF_PS025.FormCreate(Sender: TObject);
begin
    inherited;
    i:=0;
    Fax:=False;
    GBFax.SendToBack;
    LFax.Font.Color:=$00C08000;
    GBCorreo.BringToFront;
    GBCorreoElectronico.BringToFront;
    LCorreoElectronico.Font.Color:=clBlue;
    with TIdAntiFreeze.Create(self) do Active:=true;
end;



Procedure TF_PS025.FormShow(Sender: TObject);
begin
    LEmpresa.Caption:='';
    LUsuario.Caption:=ValorCamp('IDEMPLEADO', 'EMPLEADOS', 'NOMBRE', IdEmpleado);
    EAsunto.Text:=Asunto;
    EDestinatario.Text:=Destinatario;
    EFax.Clear;
    ECuerpo.Lines.Clear;
    if Cuerpo<>'' then
     ECuerpo.Lines.Add(Cuerpo);
    EPassword.Text:=Password;
    if Todos then
      CBTodos.Checked:=True
    else
      CBTodos.Checked:=False;

    if SolicitarConfirmacion then
      CBSolicitarConfirmacion.Checked:=True
    else
      CBSolicitarConfirmacion.Checked:=False;

    Mail:= True; Fax:=False; Ftp:=False;
    GBFax.SendToBack;
    LFax.Font.Color:=$00C08000;
    GBFtp.Visible:=False;
    LFtp.Font.Color:=$00C08000;
    GBCorreoElectronico.BringToFront;
    LCorreoElectronico.Font.Color:=clBlue;

    ECuerpo.Visible:=True;
    GroupBox3.Visible:=True;
    GroupBox2.Visible:=True;
end;


Procedure TF_PS025.EditAVariable;
begin
    Asunto:=EAsunto.Text;
    if not(Fax) then
      Destinatario:=EDestinatario.Text
    else
      Destinatario:=EFax.Text;

    Password:=EPassword.Text;
    Cuerpo:=ECuerpo.Lines.Text;

    if CBTodos.Checked then
      Todos:=True
    else
      Todos:=False;

    if CBSolicitarConfirmacion.Checked then
      SolicitarConfirmacion:=True
    else
      SolicitarConfirmacion:=False;
end;


procedure TF_PS025.EDestinatarioKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
    case key of
     VK_RETURN:
      begin
       key := VK_TAB;
       Perform(WM_NEXTDLGCTL,0,0);
      end;
    end;
end;

procedure TF_PS025.LCorreoElectronicoClick(Sender: TObject);
begin
    Mail:= True; Fax:=False; Ftp:=False;
    GBFax.SendToBack;
    LFax.Font.Color:=$00C08000;
    GBFtp.Visible:=False;
    LFtp.Font.Color:=$00C08000;
    GBCorreoElectronico.BringToFront;
    LCorreoElectronico.Font.Color:=clBlue;

    Label26.Enabled:=True;
    EAsunto.Enabled:=True;
    ECuerpo.Visible:=True;
    GroupBox1.Visible:=True;
end;

procedure TF_PS025.LFaxClick(Sender: TObject);
begin
    Mail:= False; Fax:=True; Ftp:=False;
    GBCorreoElectronico.SendToBack;
    LCorreoElectronico.Font.Color:=$00C08000;
    GBFtp.Visible:=False;
    LFtp.Font.Color:=$00C08000;
    GBFax.BringToFront;
    LFax.Font.Color:=clBlue;

    Label26.Enabled:=True;
    EAsunto.Enabled:=True;
    ECuerpo.Visible:=True;
    GroupBox1.Visible:=True;
end;

procedure TF_PS025.LFtpClick(Sender: TObject);
begin
    Mail:= False; Fax:=False; Ftp:=True;
    GBCorreoElectronico.SendToBack;
    LCorreoElectronico.Font.Color:=$00C08000;
    GBFax.SendToBack;
    LFax.Font.Color:=$00C08000;
    GBFtp.Visible:=True;
    GBFtp.BringToFront;
    LFtp.Font.Color:=clBlue;

    Label26.Enabled:=False;
    EAsunto.Enabled:=False;
    ECuerpo.Visible:=False;
    GroupBox1.Visible:=False;
end;

procedure TF_PS025.LlistaAdjuntsDblClick(Sender: TObject);
begin
    LlistaAdjunts.DeleteSelected;
end;

procedure TF_PS025.AdvMetroButton1Click(Sender: TObject);
begin
    ModalResult:=mrCancel;
end;

procedure TF_PS025.AdvMetroButton3Click(Sender: TObject);
var maildestinatario: TIdEMailAddressList;
    vtMensajeTexto: TStringList;
    Question: TMyQuery;
    i: Integer;
    Llista: TStringList;
begin
    Memo1.Lines.Clear;

    if (AdvMetroButton3.Tag=1) then
     begin
       ModalResult:=mrOk;
     end
    else
     begin
      GBCorreo.SendToBack;
      GBEnviando.Height:=413;
      GBEnviando.BringToFront;
      EditAVariable;

      vtMensajeTexto:=TStringList.Create;
      vtMensajeTexto.Add(Cuerpo);

      maildestinatario:=TIdEMailAddressList.Create(nil);
      // Estamos enviando mail ...
      if Mail then
       begin
        Memo1.Lines.Add('Enviando correo electrónico.');
        Memo1.Lines.Add('Espere confirmación de finalización.');
        if Todos then
         begin
          Question:=TMyQuery.Create(nil);
          Question.Connection:=D_Aplicacio.ConexionMSql;
          Question.SQL.Add(
          ' SELECT E.EMAIL FROM EMPLEADOS E, USUARIOS U '+
          ' WHERE (E.USUARIO_ASOCIADO=U.IDUSUARIO) AND (E.ACTIVO=''T'') AND NOT(E.EMAIL IS NULL) ');
          Question.Active:=True;
          Question.First;
          while not(Question.Eof) do
           begin
            maildestinatario.Add.Address := Question.FieldByName('EMAIL').AsString;
            Question.Next;
           end;
          if Assigned(Question) then
           Question.Free;
         end
        else
         begin
          for i:=1 to (ContarCaracterEnCadena(';',Destinatario)+1) do
           maildestinatario.Add.Address:= CadenaEntreSeparadors(';', i, Destinatario);
         end;
       end;

      // Estamos enviando Fax ...
      if Fax then
       begin
        Memo1.Lines.Add('Enviando fax.');
        Memo1.Lines.Add('Espere confirmación de finalización.');
        for i:=1 to (ContarCaracterEnCadena(';',Destinatario)+1) do
         maildestinatario.Add.Address:= 'fax.' + CadenaEntreSeparadors(';', i, Destinatario) + '@fax.vodafone.es';
       end;

      Question:=TMyQuery.Create(nil);
      Question.Connection:=D_Aplicacio.ConexionMSql;
      if Fax then
       begin
        Question.SQL.Add(
        ' SELECT ''Previnsa, S.L.'' AS NOMBRE, MAILFAX AS EMAIL, SERVIDOR, PUERTO '+
        ' FROM GESTORES '+
        ' WHERE (IDGESTOR=:IDGESTOR) ');
        Question.ParamByName('IDGESTOR').AsInteger:=llistaemp.GestorActiu;
        Question.Active:=True;
       end
      else
       begin
        Question.SQL.Add(
        ' SELECT E.NOMBRE, E.EMAIL, E.SERVIDOR, E.PUERTO '+
        ' FROM EMPLEADOS E, USUARIOS U '+
        ' WHERE (E.USUARIO_ASOCIADO=U.IDUSUARIO) AND (U.IDUSUARIO=:IDUSUARIO) ');
        Question.ParamByName('IDUSUARIO').AsInteger:=llistaemp.UsuariActual;
        Question.Active:=True;
       end;

      Llista:=TStringList.Create;
      Llista.Assign(LlistaAdjunts.Items);
      TThreadMail.Create(Question.FieldByName('SERVIDOR').AsString,
       Question.FieldByName('EMAIL').AsString, Password,
       Question.FieldByName('PUERTO').AsInteger, Asunto, vtMensajeTexto,
       True, Borrar, SolicitarConfirmacion, Question.FieldByName('EMAIL').AsString,
       Question.FieldByName('NOMBRE').AsString, mailDestinatario.EMailAddresses, '',
       DocumentoAdjunto, Llista);

      AdvMetroButton3.Tag:=1;
     end;
end;

procedure TF_PS025.Button1Click(Sender: TObject);
begin
    FinestraDireccions;
end;

procedure TF_PS025.Button2Click(Sender: TObject);
begin
    FinestraFax;
end;

procedure TF_PS025.Button3Click(Sender: TObject);
begin
    FinestraEmpresa;
end;

Procedure TF_PS025.EAsuntoKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
    case key of
     VK_RETURN:
      begin
       key := VK_TAB;
       Perform(WM_NEXTDLGCTL,0,0);
      end;
    end;
end;


procedure TF_PS025.Label4Click(Sender: TObject);
begin
    FinestraDocumento;
end;

procedure TF_PS025.Label5Click(Sender: TObject);
var fitxer: String;
    dialeg: TOpenDialog;
begin
    inherited;
    Dialeg:=TOpenDialog.Create(Application);
    Dialeg.Title:='Ficheros adjuntos';
    Dialeg.Filter:='Ficheros adjuntos|*.*;';
    If not dialeg.Execute then
     begin
         if Assigned(Dialeg) then
          Dialeg.free;
         Exit;
     end;
    Fitxer:=Dialeg.FileName;

    try
     LlistaAdjunts.Items.Add(fitxer);
    except
    end;

    if Assigned(Dialeg) then
     Dialeg.Free;
end;

procedure TF_PS025.Label6Click(Sender: TObject);
begin
    LlistaAdjunts.DeleteSelected;
end;

procedure TF_PS025.Label8Click(Sender: TObject);
begin
    AdvMetroButton3.Tag:=0;
    GBCorreo.BringToFront;
    GBEnviando.Height:=293;
    GBEnviando.SendToBack;
end;


{ ThReadMail }
constructor TThreadMail.Create(
    ServidorUsuario, MailUsuario, PassUsuario : String;
    PuertoUsuario : Integer;
    Asunto: String;
    Mensaje: TStringList;
    Autenticacion, Borrar, SolicitarConfirmacion: Boolean;
    Emisor, NombreEmisor: String;
    MailsDestinatarios: String;
    Cc, Adjunto: String; ListaAdjuntos: TStringList);
begin
    IdSSLOpenSSLHeaders.Load;
    TServidorUsuario:=ServidorUsuario;
    TMailUsuario:=MailUsuario;
    TPassUsuario:=PassUsuario;
    TPuertoUsuario:=PuertoUsuario;
    TAsunto:=Asunto;
    TMensaje:=Mensaje;
    TAutenticacion:=Autenticacion;
    TEmisor:=Emisor;
    TNombreEmisor:=NombreEmisor;
    TDestinatario:=MailsDestinatarios;
    TCC:=Cc;
    TAdjunto:=Adjunto;
    TSolicitarConfirmacion:=SolicitarConfirmacion;
    TBorrar:=Borrar;
    TListaAdjuntos:=ListaAdjuntos;
    OnTerminate := F_PS025.ThreadDone;
    FreeOnTerminate := True;
    inherited create(false);
end;


// Envía un mensaje al finalizar todos los Threads activos
procedure TF_PS025.ThreadDone(Sender: TObject);
begin
   //MessageDlg('Hilo Creado', mtinformation, [mbok], 0);
end;


Procedure TThreadMail.Execute;
var compMensaje : TIdMessage;
    i: SmallInt;
begin
  IdSSLOpenSSLHeaders.Load;

  compIoHandler:=TIdSSLIOHandlerSocketOpenSSL.Create(nil);
  compIoHandler.RecvBufferSize := 65000;
  compIoHandler.SendBufferSize := 65000;
  compIoHandler.PassThrough := True;
  compIoHandler.SSLOptions.Method := sslvTLSv1;//sslvSSLv2;//sslvSSLv3;
  compIoHandler.SSLOptions.Mode :=sslmUnassigned ;
  compIoHandler.SSLOptions.VerifyMode := [];
  compIoHandler.SSLOptions.VerifyDepth := 0;
  compIoHandler.Host := TServidorUsuario;
  compIoHandler.Destination := TServidorUsuario + ':' + IntToStr(TPuertoUsuario);
  compIoHandler.DefaultPort := 0;
  compIoHandler.Port := TPuertoUsuario;
  compIoHandler.UseNagle := False;

  compEnvioEmail:=TIdSMTP.Create(nil);
  compEnvioEmail.PipeLine:=False;
  compEnvioEmail.UseEhlo:=True;
  compEnvioEmail.IOHandler:=compIoHandler;
  compEnvioEmail.Host:=TServidorUsuario;
  compEnvioEmail.Port:=TPuertoUsuario;

  if (TPuertoUsuario = 465) then
   compEnvioEmail.UseTLS:= utUseImplicitTLS
  else
   compEnvioEmail.UseTLS:= utUseExplicitTLS;

  if TAutenticacion then
   compEnvioEmail.AuthType := satDefault
  else
   compEnvioEmail.AuthType := satNone;

  compEnvioEmail.Password:=TPassUsuario;
  compEnvioEmail.Username:=TMailUsuario;

  try
    compEnvioEmail.connect;
  except
    MensajeDialogo('Error en la conexión con el servidor.', mtError, [mbAceptar], '');
    compEnvioEmail.Free;
    Exit;
  end;

  compMensaje := TIdMessage.Create (nil);
  compMensaje.From.Address := TMailUsuario;
  compMensaje.From.User := TMailUsuario;
  compMensaje.From.Name := TNombreEmisor;
  compMensaje.ReplyTo.Add.Address := TMailUsuario;
  compMensaje.CharSet := 'ISO-8859-2'; //'UTF-8';

  compMensaje.Recipients.EMailAddresses := TDestinatario;

  compMensaje.Priority := TIdMessagePriority(mpHighest); // prioridad del mensaje
  compMensaje.Body.AddStrings (Tmensaje);
  compMensaje.Subject := TAsunto;

  if TSolicitarConfirmacion then
   begin
    compMensaje.ReceiptRecipient.Text := compMensaje.From.Text;
    compMensaje.ReceiptRecipient.Address := TEmisor;
    compMensaje.ReceiptRecipient.Name := TNombreEmisor;
   end;

  if ((TAdjunto<>'') and (TAdjunto <> NULL)) then
   TIdAttachmentFile.Create(compMensaje.MessageParts, TAdjunto);

  for i:=0 to TListaAdjuntos.Count-1 do
   if Fileexists(TListaAdjuntos.Strings[i]) then
     TIdAttachmentFile.Create(compMensaje.MessageParts, TListaAdjuntos.Strings[i]);

  try
    //Synchronize(InicioEnvio);
    compEnvioEmail.Send(compMensaje);
    Synchronize(EnvioFinalizado);
  except
     on E: Exception do
      begin
          Tex:=E;
          Synchronize(HandleException);
      end;
  end;

  compMensaje.Free;
  TFinalitzar:=True;
end;

// Inicio de envío con TUploaderThread
procedure TThreadMail.InicioEnvio;
begin
    //F_PS025.Label8.Enabled:=False;
end;

// Fin de envío con TUploaderThread
procedure TThreadMail.EnvioFinalizado;
begin
    MensajeDialogo('Envio finalizado con éxito.', mtAviso, [mbAceptar], '');
    F_PS025.Memo1.lines.add('Envio finalizado con éxito.');
end;

// Error de envío con TUploaderThread
procedure TThreadMail.HandleException;
begin
    MensajeDialogo('Error en el envio - ' + Tex.Message, mtAviso, [mbAceptar], '');
    F_PS025.Memo1.Lines.Add('Error en el envio. ' + Tex.Message);
end;

end.

Y la creación del Form:

Código Delphi [-]
Function EnviarCorreoAdjunto(Asunto, Mensaje, PathDocumento, Destinatarios: String; Borrar: Boolean):Boolean;
var F_PS025: TF_PS025;
begin
        F_PS025:=TF_PS025.Create(nil);
        F_PS025.Asunto:=Asunto;
        F_PS025.Destinatario:=Destinatarios;
        F_PS025.Cuerpo:=Mensaje;
        F_PS025.Password:='';
        F_PS025.Todos:=False;
        F_PS025.DocumentoAdjunto:=PathDocumento;
        F_PS025.Borrar:=Borrar;
        F_PS025.SolicitarConfirmacion:=False;

        F_PS025.ShowModal;

        if Assigned(F_PS025) then
         F_PS025.Free;
        EnviarCorreoAdjunto:=True;
end;

El error aparece en:

Código Delphi [-]
// Fin de envío con TUploaderThread
procedure TThreadMail.EnvioFinalizado;
begin
    F_PS025.Memo1.lines.add('Envio finalizado con éxito.');
end;

Cuando en el Execute se llama a

Código Delphi [-]
Synchronize(EnvioFinalizado);

En Debug, poniendo un break en la linea donde me aparece el Access Violation, el F_PS025 lo tengo a "nil" y sus componentes no tienen valor...

Jose.

[[nlsgarcia]]

Broskil Giovann,

Empezado por Broskil Giovann

...Te adjunto todo el código para que lo veas...En Debug...el F_PS025 lo tengo a "nil" y sus componentes no tienen valor...

Te comento:

1- La función EnviarCorreoAdjunto instancia y libera el formulario TF_PS025.

2- La declaración de la función EnviarCorreoAdjunto esta en en código del Msg #12, pero la llamada a la función ¿Donde esta?.

3- Al parecer, según lo mostrado en el código del Msg #12, el formulario TF_PS025 no esta instanciado y por ello al ejecutar Synchronize(EnvioFinalizado) se produce el error de Access Violation, dado que se trata de acceder en runtime a un objeto que no ha sido creado previamente.

4- Revisa este código:

Código Delphi [-]
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses Unit2;

function ShowModalForm2(Msg : String) : Boolean;
var
   Form2 : TForm2;
   i : Integer;
   
begin

   try

      Form2 := TForm2.Create(nil);

      with Form2 do
         for i := 0 to 10 do
            Memo1.Lines.Add('Line-' + IntToStr(i) + ' ' + Msg);

      Form2.ShowModal;

      if Assigned(Form2) then
         Form2.Free;

      Result := True;

   except

      Result := False;

   end;

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   if ShowModalForm2('Text') then
      MessageDlg('La función ShowModalForm2 fue ejecutada correctamente',mtInformation,[mbOK],0)
   else
      MessageDlg('Error al ejecutar la función ShowModalForm2',mtError,[mbOK],0);
end;

end.

El código anterior instancia y libera el formulario TForm2 por medio de la función ShowModalForm2 y carga 11 líneas en el componente TMemo1, si se comenta la línea Form2 := TForm2.Create(nil) se producirá un Access Violation (Gestionado por try...except statements), al ejecutar la línea Memo1.Lines.Add('Line-' + IntToStr(i) + ' ' + Msg) dado que el objeto que contiene al componente nunca fue creado.

Espero sea útil

Nelson.