Discussione: Corso VBA
Visualizza messaggio singolo
Vecchio 27-07-2014, 10.10.43   #49
Alexsandra
Senior Member
WT Expert
 
L'avatar di Alexsandra
 
Registrato: 19-05-2007
Loc.: Verona
Messaggi: 1.302
Alexsandra è conosciuto da tuttiAlexsandra è conosciuto da tuttiAlexsandra è conosciuto da tuttiAlexsandra è conosciuto da tuttiAlexsandra è conosciuto da tutti
Invio di una e-mail utilizzando un server remoto con CDO




Il funzionamento di un servizio di posta elettronica è garantito dalla collaborazione di tre distinti software: un server che si occupa della consegna dei messaggi (protocollo SMTP), un server che riceve i messaggi, li archivia e li trasmette, su richiesta, al titolare della casella (protocollo POP3 o IMAP) e un client che, dal PC dell'utente, è in grado di inviare e ricevere e-mail collegandosi e dialogando con le due parti server del servizio. I Web server non offrono funzionalità di posta elettronica, tuttavia le macchine che ospitano servizi Web, spesso e volentieri, permettono anche l'invio delle e-mail, tramite un apposito server SMTP.

A partire dalla versione Windows NT/2000, è stata integrata una libreria COM, chiamata CDO, che è l’acronimo di Collaboration Data Object, contenuta nel file Cdosys.dll, e permette di spedire e-mail attraverso il protocollo SMTP (Simple Mail Transfert Protocol) del Sistema Operativo, senza alcun bisogno di utilizzare un client. Vedremo come è possibile sfruttare il server SMPT presente nel sistema per inviare e-mail generate dinamicamente aiutandoci con qualche esempio.

Esempio 1: Inviare una e-mail utilizzando Gmail.
Per poter utilizzare gli oggetti della libreria CDO è innanzitutto indispensabile istanziare tali oggetti. In questo esempio useremo solo l’oggetto CDO.Message in cui verrà definito il messaggio stesso e per istanziare l’oggetto useremo il comando: Set cdoMess = CreateObject("CDO.message"). La routine completa è la seguente
Codice:
Sub inviaE()
'istanza dell'oggetto CDO
Set cdoMess = CreateObject("CDO.message")

'Impostare i parametri di configurazione del server remoto
With cdoMess.Configuration.Fields
‘Indicare come il messaggio deve essere inviato. I valori sono:
‘1 – Si utilizza questo valore se il servizio SMTP è installato nel computer in cui lo script è in esecuzione.
‘2 – Si utilizza questo valore se il servizio SMTP non è installato nel computer in cui lo script è in esecuzione.
  .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'Impostare il server SMTP che si utilizza
  .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
'Impostare la porta di comunicazione del server SMTP
  .Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 587
'Abilitare autenticazione SMTP, il valore 1 indica True 
  .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
‘Abilita autenticazione SSL 
  .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
‘Timeout di connessione in secondi (il tempo massimo in cui CDO tenterà di stabilire una connessione al server SMTP
  .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
'Impostare le credenziali del vostro account Gmail
  .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "prova@gmail.com"
  .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "pass1234"
'Aggiorna i campi di configurazione  
  .Update
End With

’Proprietà del messaggio
With cdoMess
‘Inserire l’indirizzo del destinatario. E’ possibile inserire più indirizzi separandoli con una virgola
  .To = info.prova@gmail.com
‘Inserire il nominativo del mittente della e-mail
  .From = prova@gmail.com
‘Inserire l'oggetto della e-mail
  .Subject = "Invio email con CDO"
‘Inserire il corpo della email in testo semplice
  .TextBody = "Inserire il corpo del messaggio." & vbCRLF & "Si consiglia di creare una variabile per contenere tutto il testo"
‘Spedizione della mail
  .Send
End With

    Set cdoMess = Nothing
End Sub
Il codice sopra riportato è ampiamente commentato e non serve aggiungere ulteriori spiegazioni, possiamo però perfezionare il codice aggiungendo altri parametri. Per esempio, supponiamo di avere i dati di spedizione della mail in un foglio di lavoro denominato “Setup” e di doverli recuperare in automatico.

Fig. 1

In questi casi sarebbe opportuno dividere la procedura in 2 routine, in cui una si occupa di recuperare i dati presenti nel foglio di lavoro e passarli alla seconda che li processerà e invierà l’email. Per recuperare i dati dal foglio “Setup” possiamo usare un codice come il seguente:
Codice:
 Sub Prova()
 Dim Eto As String, Efrom As String, Eogg As String, Emess As String, Esmtp As String, Epass As String 
        Eto = Sheets("setup").Range("B2")
        Efrom = Sheets("setup").Range("B1")
        Eogg = Sheets("setup").Range("B3")
        Emess = Sheets("setup").Range("B4")
        Esmtp = Sheets("setup").Range("B5")
        Epass = Sheets("setup").Range("B6")
    inviaE Eto, Efrom, Eogg, Emess, Esmtp, Epass
End Sub
Mentre la routine che invierà la mail presenterà questo codice
Codice:
Sub inviaE(Eto As String, Efrom As String, Eogg As String, Emess As String, Esmtp As String, Epass As String)
'istanza dell'oggetto CDO
Set cdoMess = CreateObject("CDO.message")

With cdoMess.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Esmtp
.Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 587
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Efrom
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Epass
.Update
End With

With cdoMess
.To = Eto
.From = Efrom
.Subject = Eogg
.TextBody = Emess
.Send
End With

Set cdoMess = Nothing
End Sub
Possiamo anche allegare uno o più file al messaggio modificando il ciclo With in questo modo:
Codice:
With cdoMess
.To = Eto
.From = Efrom
.Subject = Eogg
.TextBody = Emess
.AddAttachment "C:\Test\info.txt"
.Send
End With
Oppure inserire il percorso nel foglio “Setup” e allegarlo sotto forma di variabile come visto in precedenza.
A volte può presentarsi la necessità di dover spedire delle email con un testo standard, può essere una promozione di certi prodotti, oppure un avviso qualsiasi, in questi casi è possibile inserire il testo presente in un file nel corpo della mail in questo modo:
Codice:
  'Queste costanti sono definite per rendere il codice più leggibile
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
'Aprire il file in lettura
Set f = fso.OpenTextFile("C:\Test\annuncio.txt", ForReading)
'Il metodo ReadAll legge l'intero file nella variabile BodyText
BodyText = f.ReadAll
'Chiudi il file
f.Close
Set f = Nothing
Set fso = Nothing

With cdoMess
.To = Eto
.From = Efrom
.Subject = Eogg
.TextBody = BodyText
.Send
End With

Set cdoMess = Nothing
End Sub
Il codice sopra riportato mostra come leggere il contenuto di un file (annuncio.txt) e inserirlo in una variabile (BodyText) che costituirà il corpo del messaggio. La routine completa in questo caso diventa:
Codice:
 Sub inviaE(Eto As String, Efrom As String, Eogg As String, Emess As String, Esmtp As String, Epass As String)
'istanza dell'oggetto CDO
Set cdoMess = CreateObject("CDO.message")

With cdoMess.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Esmtp
.Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 587
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Efrom
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Epass
.Update
End With

'Queste costanti sono definite per rendere il codice più leggibile
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
'Aprire il file in lettura
Set f = fso.OpenTextFile("C:\Test\annuncio.txt", ForReading)
'Il metodo ReadAll legge l'intero file nella variabile BodyText
BodyText = f.ReadAll
'Chiudi il file
f.Close
Set f = Nothing
Set fso = Nothing

With cdoMess
.To = Eto
.From = Efrom
.Subject = Eogg
.TextBody = BodyText
.Send
End With

Set cdoMess = Nothing
End Sub

Sub Prova()
    Dim Eto As String, Efrom As String, Eogg As String, Emess As String, Esmtp As String, Epass As String

        Eto = Sheets("setup").Range("B2")
        Efrom = Sheets("setup").Range("B1")
        Eogg = Sheets("setup").Range("B3")
        Emess = Sheets("setup").Range("B4")
        Esmtp = Sheets("setup").Range("B5")
        Epass = Sheets("setup").Range("B6")
     
    inviaE Eto, Efrom, Eogg, Emess, Esmtp, Epass

End Sub
A questo punto si dovrebbe aggiungere al codice una corretta gestione degli errori per evitare e prevenire errori quando la routine è in esecuzione. Possiamo modificare il listato come di seguito riportato
Codice:
Sub inviaE(Eto As String, Efrom As String, Eogg As String, Emess As String, Esmtp As String, Epass As String)
'istanza dell'oggetto CDO
Set cdoMess = CreateObject("CDO.message")
'Gestione errori
On Error GoTo err

With cdoMess.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Esmtp
.Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 587
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Efrom
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Epass
.Update
End With

'Queste costanti sono definite per rendere il codice più leggibile
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
[COLOR="green"]'Aprire il file in lettura
Set f = fso.OpenTextFile("C:\Test\annuncio.txt", ForReading)
'Il metodo ReadAll legge l'intero file nella variabile BodyText
BodyText = f.ReadAll
'Chiudi il file
f.Close
Set f = Nothing
Set fso = Nothing

With cdoMess
.To = Eto
.From = Efrom
.Subject = Eogg
.TextBody = BodyText
.Send
End With

Set cdoMess = Nothing

err:
 If err.Number = 53 Then
        MsgBox "Manca il file da allegare. Procedura terminata"
        Exit Sub
    End If
End Sub
Sub Prova()

    Dim Eto As String, Efrom As String, Eogg As String, Emess As String, Esmtp As String, Epass As String
    
   'controllo se esiste il destinatario
    If Trim(Sheets("setup").Range("B2")) = "" Then
        MsgBox "Manca Il Destinatario"
        Exit Sub
         Else
           Eto = Sheets("setup").Range("B2")
    End If

           'controllo se esiste il mittente
          If Trim(Sheets("setup").Range("B1")) = "" Then
            MsgBox "Manca Il Mittente"
            Exit Sub
              Else
               Efrom = Sheets("setup").Range("B1")
           End If
    
         'controllo è stato inserito l'oggetto della mail
          If Trim(Sheets("setup").Range("B3")) = "" Then
            MsgBox "Manca L'Oggetto della Mail"
            Exit Sub
              Else
               Eogg = Sheets("setup").Range("B3")
           End If
        
    Emess = Sheets("setup").Range("B4")
    
            'controllo se ci sono i dati dell'smtp
          If Trim(Sheets("setup").Range("B5")) = "" Then
            MsgBox "Manca SMTP da usare"
            Exit Sub
              Else
               Esmtp = Sheets("setup").Range("B5")
           End If
    
           'controllo se c'è la password per l'smtp
          If Trim(Sheets("setup").Range("B6")) = "" Then
            MsgBox "Manca la password dell'SMTP da usare"
            Exit Sub
              Else
               Epass = Sheets("setup").Range("B6")
           End If
     
    inviaE Eto, Efrom, Eogg, Emess, Esmtp, Epass

End Sub
___________________________________

- Il primo fondamento della sicurezza non e' la tecnologia, ma l'attitudine mentale -
Alexsandra non è collegato   Rispondi citando