Macro per inviare email

Hai un problema con Excel?

Nuova discussione

Macro per inviare e-mail
di marnevi (utente non iscritto) data: 27/11/2015 15:17:52
Ciao ragazzi.
Ho preso come riferimento la seguente macro che fu postata tempo fa su questo forum e che funziona correttamente.

La domanda è questa: se io avessi bisogno di inviare la stessa e-mail a più indirizzi (circa una decina), tutti elencati in una colonna del foglio nominato Foglio1, cosa e come dovrei modificare questa macro?

Sub InviaMail()
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant
    Dim MittenteMail, OggettoMail, DestinatarioMail As String
Dim Da, Text, Ogg, achiTo, achiCC, achiBCC, Att1, Att2, Att3, codice, server, port As String
Da = Range("A2")  ' indirizzo accesso
codice = Range("Q2") 'password accesso
Text = Range("I2") ' Testo - Ricorda che nella cella di inserimento (I2) per andare a capo basta premere Alt Invio
Ogg = Range("H2") ' breve descrizione dell'oggetto del messaggio
achiTo = Range("B2") ' indirizzi di posta elettronica dei destinatari principali.
achiCC = Range("D2") ' indirizzi di posta elettronica dei destinatari in copia conoscenza
achiBCC = Range("F2") ' indirizzi di posta elettronica dei destinatari in copia conoscenza nascosta, ovvero destinatari che riceveranno il messaggio ma il cui indirizzo non apparirà tra i destinatari.
Att1 = Range("J2")      ' percorso primo file allegato
Att2 = Range("K2")     ' percorso secondo file allegato
Att3 = Range("L2")     ' percorso terzo file allegato
server = Range("R2")   ' server
port = Range("S2")       ' porta
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
' TOGLIERE LO SPAZIO in "ht tp://
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/sendusername") = Da        ' indirizzo accesso
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/sendpassword") = codice   'password accesso
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/smtpserver") = server
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/smtpserverport") = port
        .Update
    End With
   
    strbody = Ogg
DestinatarioMail = achiTo
    With iMsg
        Set .Configuration = iConf
        .To = achiTo
        .CC = achiCC
        .BCC = achiBCC
        MittenteMail = Da
        OggettoMail = Ogg
        .From = Da
        .Subject = Ogg
        .TextBody = Text
        If Att1 <> "" Then
        .AddAttachment Att1 ' <<<<<<<<< primo file
        End If
        If Att2 <> "" Then
        .AddAttachment Att2 ' <<<<<<<<< secondo file
        End If
        If Att3 <> "" Then
        .AddAttachment Att3 ' <<<<<<<<< terzo file
        End If
        .Send
    End With
End Sub

di Albatros54 data: 27/11/2015 16:08:06
Prova cosi. Naturalmente devi cambiare i tuoi riferimenti ai Range che contengono gli indirizzi.
Ciao
albatros54

Sub InviaMail()
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant
    Dim MittenteMail, OggettoMail, DestinatarioMail As String
Dim Da, Text, Ogg, Att1, Att2, Att3, codice, server, achiCC, achiBCC, port As String
Dim achiTo As Range
Set achiTo = Range("b2:B11")
Da = Range("A2")  ' indirizzo accesso
codice = Range("Q2") 'password accesso
Text = Range("I2") ' Testo - Ricorda che nella cella di inserimento (I2) per andare a capo basta premere Alt Invio
Ogg = Range("H2") ' breve descrizione dell'oggetto del messaggio
'achiTo = Range("B2") ' indirizzi di posta elettronica dei destinatari principali.
achiCC = Range("D2") ' indirizzi di posta elettronica dei destinatari in copia conoscenza
achiBCC = Range("F2") ' indirizzi di posta elettronica dei destinatari in copia conoscenza nascosta, ovvero destinatari che riceveranno il messaggio ma il cui indirizzo non apparirà tra i destinatari.
Att1 = Range("J2")      ' percorso primo file allegato
Att2 = Range("K2")     ' percorso secondo file allegato
Att3 = Range("L2")     ' percorso terzo file allegato
server = Range("R2")   ' server
port = Range("S2")       ' porta
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    iConf.Load -1    ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
' TOGLIERE LO SPAZIO in "ht tp://
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/sendusername") = Da        ' indirizzo accesso
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/sendpassword") = codice   'password accesso
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/smtpserver") = server
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("ht tp://schemas.microsoft.com/cdo/configuration/smtpserverport") = port
        .Update
    End With
   
    strbody = Ogg
    For Each cl In achiTo
   DestinatarioMail = cl
    With iMsg
        Set .Configuration = iConf
        .To = cl
        .CC = achiCC
        .BCC = achiBCC
        MittenteMail = Da
        OggettoMail = Ogg
        .From = Da
        .Subject = Ogg
        .TextBody = Text
        If Att1 <> "" Then
        .AddAttachment Att1 ' <<<<<<<<< primo file
        End If
        If Att2 <> "" Then
        .AddAttachment Att2 ' <<<<<<<<< secondo file
        End If
        If Att3 <> "" Then
        .AddAttachment Att3 ' <<<<<<<<< terzo file
        End If
        .Send
    End With
       Next
   
End Sub

di Luca73 data: 30/11/2015 10:28:25
Ciao A tutti
Ciao Albatros io proverei a far a creare l'elenco di indirizzi (bisogna verificare qual'è il carattere di separazione (, ; :)

Ciao
Luca

Sub InviaMail()

[...]
   DestinatarioMail=""
   For Each cl In achiTo
      DestinatarioMail = DestinatarioMail & cl & "; "
   Next
      DestinatarioMail = left(DestinatarioMail; len(DestinatarioMail)-2)
      With iMsg
        .To = cl
        .CC = achiCC
        .BCC = achiBCC
        MittenteMail = Da
        OggettoMail = Ogg
        .From = Da
        .Subject = Ogg
        .TextBody = Text
        If Att1 <> "" Then
        .AddAttachment Att1 ' <<<<<<<<< primo file
        End If
        If Att2 <> "" Then
        .AddAttachment Att2 ' <<<<<<<<< secondo file
        End If
        If Att3 <> "" Then
        .AddAttachment Att3 ' <<<<<<<<< terzo file
        End If
        .Send
    End With
  
End Sub

di marnevi (utente non iscritto) data: 30/11/2015 10:37:26
provo entrambe le soluzioni e vi faccio sapere. grazie

Vuoi Approfondire?