Condividi tramite

Macro per inviare email con allegati

Anonimo
2022-02-25T18:18:35+00:00

Ciao a tutti,

Cercando fra i vari thread ho trovato il codice che allego sotto scritto da Norman. L'ho trovato molto utile perché è adatto alle mie esigenze. Ho creato una tabella con le varie voci riportate nel codice, e quello che mi manca, è di avere la possibilità di poter allegare più di un file. Va notato che i file si trovano in un'unica cartella, pertanto nella tabella oltre a riportare il percorso con i vari indirizzi di posta elettronica, riporto nella colonna F il nome del file da allegare.

Quello che bisogna aggiungere è di poter allegare fino a 5 file. Pertanto il codice va esteso fino alla colonna J. Con questo non voglio dire che tutti gli indirizzi di posta elettronica riceveranno tutti 5 file allegati. Infatti potrebbero variare, chi uno, chi due e chi cinque. Io ho provato ad estendere gli allegati sul codice che riporto in grassetto, ma non funziona. Il codice è questo:

Public Sub Tester() 

Dim WB As Workbook 

Dim SH As Worksheet 

Dim Rng As Range 

Dim arrIn As Variant 

Dim oOutlook As Object 

Dim oMail As Object 

Dim sIndirizzo As String 

Dim sNome As String 

Dim sCognome As String 

Dim sTitolo As String 

Dim sPercorso As String 

Dim sAllegato As String, sAllegato2 As String 

Dim sAllegato3 As String, sAllegato4 as String, sAllegato5 as String 

Dim sbody As String 

Dim LRow As Long, i As Long 

Const sFoglio As String = "Foglio1"                      '<<=== Modifica 

Const sOggetto As String = "Vote for Trump"     '<<=== Modifica 

Const sEmailContatto As String = \_ 

                         "provachiocciola.hotmail.com"         '<<=== Modifica 

Set WB = ThisWorkbook 

Set SH = WB.Sheets(sFoglio) 

With SH 

    LRow = LastRow(SH, .Columns("A:A")) 

    Set Rng = .Range("A2:J" & LRow) 

End With 

arrIn = Rng.Value2 

Set oOutlook = CreateObject("Outlook.Application") 

For i = 1 To UBound(arrIn) 

    Set oMail = oOutlook.CreateItem(0) 

    With oMail 

        sIndirizzo = arrIn(i, 1) 

        sCognome = arrIn(i, 2) 

        sNome = arrIn(i, 3) 

        sTitolo = arrIn(i, 4) 

        sPercorso = arrIn(i, 5) 

        sAllegato = arrIn(i, 6) 

        **sAllegato2 = arrIn(i, 7)** 

        **sAllegato3 = arrIn(i, 8)** 

        **sAllegato3 = arrIn(i, 9)** 

        **sAllegato3 = arrIn(i, 10)** 

        sbody = "<H3><B>Gentile " & sNome & " " \_ 

                & sCognome & ",</B></H3>" & \_ 

                "la tua iscrizione al corso XXYY di Volley del  " & \_ 

                "25 febbraio 2018" & \_ 

                " presso l'istituto ZZKK sito in via Padova, 40 a Milano" & \_ 

                " è stata registrata." & \_ 

                "<br><br>Per confermare l'iscrizione è necessario effettuare" & \_ 

                " il pagamento entro e non oltre domenica 18 febbraio 2018." & \_ 

                "<br><br>Per qualsiasi chiarimento o dubbio, contatta " & \_ 

                "la Segreteria allo 02/xxxxxxxx o scrivi a:" & Space(1) & \_ 

                " <B>" & sEmailContatto & "</B>" & \_ 

                "<br><br>Cordiali saluti<br>" & \_ 

                "<br><B>Cognome  nome</B><br>" & \_ 

                "Segreteria di direzione" & \_ 

                "<br>Nome Azienda<br>" & \_ 

                "N°telefono<br>" & \_ 

                "sito web<br>" & \_ 

                "indirizzo mail<br>" 

        .display 

        .To = sIndirizzo 

        .CC = "" 

        .BCC = "" 

        .Subject = sOggetto 

        .HTMLBody = sbody & "<br>" & .HTMLBody 

        .Attachments.Add sPercorso \_ 

                         & Application.PathSeparator \_ 

                         & sAllegato  **& sAllegato2 & sAllegato3 & sAllegato4 & sAllegato5**

        .display    'Send 

    End With 

    Set oMail = Nothing 

Next i 

Set oMail = Nothing 

Set oOutlook = Nothing

End Sub

Grazie come sempre per l'aiuto.

Microsoft 365 e Office | Excel | Per la casa | Windows

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo
2022-02-25T20:23:53+00:00

Ciao Geacs,

Avevo trascurato la possibilità che alcuni destinatari possano ricevere meno allegati!

Pertanto sostituisci il codice con:

'========>>

Option Explicit

'-------->>

Public Sub Tester() 

Dim WB As Workbook 

Dim SH As Worksheet 

Dim Rng As Range 

Dim arrIn As Variant 

Dim oOutlook As Object 

Dim oMail As Object 

Dim sIndirizzo As String 

Dim sNome As String 

Dim sCognome As String 

Dim sTitolo As String 

Dim sPercorso As String 

Dim sAllegato As String, sAllegato2 As String 

Dim sAllegato3 As String, sAllegato4 As String, sAllegato5 As String 

Dim sbody As String 

Dim LRow As Long, i As Long 

Const sFoglio As String = **"Foglio1"                                                          '<<=== Modifica** 

Const sOggetto As String = **"Vote for Trump"                                         '<<=== Modifica** 

Const sEmailContatto As String = **"provachiocciola.hotmail.com"         '<<=== Modifica** 

Set WB = ThisWorkbook 

Set SH = WB.Sheets(sFoglio) 

With SH 

    LRow = LastRow(SH, .Columns("A:A")) 

    Set Rng = .Range("A2:J" & LRow) 

End With 

arrIn = Rng.Value2 

Set oOutlook = CreateObject("Outlook.Application") 

For i = 1 To UBound(arrIn) 

    Set oMail = oOutlook.CreateItem(0) 

    With oMail 

        sIndirizzo = arrIn(i, 1) 

        sCognome = arrIn(i, 2) 

        sNome = arrIn(i, 3) 

        sTitolo = arrIn(i, 4) 

        sPercorso = arrIn(i, 5) 

        sAllegato = arrIn(i, 6) 

        sAllegato2 = arrIn(i, 7) 

        sAllegato3 = arrIn(i, 8) 

        sAllegato4 = arrIn(i, 9) 

        sAllegato5 = arrIn(i, 10) 

        sbody = "<H3><B>Gentile " & sNome & " " \_ 

            & sCognome & ",</B></H3>" & \_ 

            "la tua iscrizione al corso XXYY di Volley del  " & \_ 

            "25 febbraio 2018" & \_ 

            " presso l'istituto ZZKK sito in via Padova, 40 a Milano" & \_ 

            " è stata registrata." & \_ 

            "<br><br>Per confermare l'iscrizione è necessario effettuare" & \_ 

            " il pagamento entro e non oltre domenica 18 febbraio 2018." & \_ 

            "<br><br>Per qualsiasi chiarimento o dubbio, contatta " & \_ 

            "la Segreteria allo 02/xxxxxxxx o scrivi a:" & Space(1) & \_ 

            " <B>" & sEmailContatto & "</B>" & \_ 

            "<br><br>Cordiali saluti<br>" & \_ 

            "<br><B>Cognome  nome</B><br>" & \_ 

            "Segreteria di direzione" & \_ 

            "<br>Nome Azienda<br>" & \_ 

            "N°telefono<br>" & \_ 

            "sito web<br>" & \_ 

            "indirizzo mail<br>" 

        .To = sIndirizzo 

        .CC = "" 

        .BCC = "" 

        .Subject = sOggetto 

        .HTMLBody = sbody & "<br>" & .HTMLBody 

        .Attachments.Add sPercorso \_ 

            & Application.PathSeparator \_ 

            & sAllegato 

        If sAllegato2 <> vbNullString Then 

            .Attachments.Add sPercorso \_ 

                & Application.PathSeparator \_ 

                & sAllegato2 

        End If 

        If sAllegato3 <> vbNullString Then 

            .Attachments.Add sPercorso \_ 

                & Application.PathSeparator \_ 

                & sAllegato3 

        End If 

        If sAllegato4 <> vbNullString Then 

            .Attachments.Add sPercorso \_ 

                & Application.PathSeparator \_ 

                & sAllegato4 

        End If 

        If sAllegato5 <> vbNullString Then 

            .Attachments.Add sPercorso \_ 

                & Application.PathSeparator \_ 

                & sAllegato5 

        End If 

        .display    'Send 

    End With 

    Set oMail = Nothing 

Next i 

Set oMail = Nothing 

Set oOutlook = Nothing

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _ 

Optional Rng As Range, \_ 

Optional minRow As Long = 1) 

If Rng Is Nothing Then 

    Set Rng = SH.Cells 

End If 

On Error Resume Next 

LastRow = Rng.Find(What:="\*", \_ 

    After:=Rng.Cells(1), \_ 

    Lookat:=xlPart, \_ 

    LookIn:=xlFormulas, \_ 

    SearchOrder:=xlByRows, \_ 

    SearchDirection:=xlPrevious, \_ 

    MatchCase:=False).Row 

On Error GoTo 0 

If LastRow < minRow Then 

    LastRow = minRow 

End If

End Function

'<<========

===

Regards,

Norman

Immagine

La risposta è stata utile?

1 persona ha trovato utile questa risposta.
0 commenti

3 risposte aggiuntive

Ordina per: Più utili
Più utili Più recente Meno recente
  1. Anonimo
    2022-02-26T10:02:07+00:00

    Ciao Geacs,

    Grazie di tutto, funziona in modo fantastico e perfetto.

    Sono lieto che il codice ti sia stato utile e ti ringrazio per il cortese riscontro.

    Alla prossima.

    ===

    Regards,

    Norman

    Immagine

    La risposta è stata utile?

    0 commenti
  2. Anonimo
    2022-02-26T08:35:12+00:00

    Ciao Norman,

    Grazie di tutto, funziona in modo fantastico e perfetto.

    La risposta è stata utile?

    0 commenti
  3. Anonimo
    2022-02-25T19:33:17+00:00

    Ciao Geacs,

    Cercando fra i vari thread ho trovato il codice che allego sotto scritto da Norman. L'ho trovato molto utile perché è adatto alle mie esigenze. Ho creato una tabella con le varie voci riportate nel codice, e quello che mi manca, è di avere la possibilità di poter allegare più di un file. Va notato che i file si trovano in un'unica cartella, pertanto nella tabella oltre a riportare il percorso con i vari indirizzi di posta elettronica, riporto nella colonna F il nome del file da allegare.

    Quello che bisogna aggiungere è di poter allegare fino a 5 file. Pertanto il codice va esteso fino alla colonna J. Con questo non voglio dire che tutti gli indirizzi di posta elettronica riceveranno tutti 5 file allegati. Infatti potrebbero variare, chi uno, chi due e chi cinque. Io ho provato ad estendere gli allegati sul codice che riporto in grassetto, ma non funziona. Il codice è questo:

    Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range

    Dim arrIn As Variant

    Dim oOutlook As Object

    Dim oMail As Object

    Dim sIndirizzo As String

    Dim sNome As String

    Dim sCognome As String

    Dim sTitolo As String

    Dim sPercorso As String

    Dim sAllegato As String, sAllegato2 As String

    Dim sAllegato3 As String, sAllegato4 as String, sAllegato5 as String

    Dim sbody As String

    Dim LRow As Long, i As Long

    Const sFoglio As String = "Foglio1" '<<=== Modifica

    Const sOggetto As String = "Vote for Trump" '<<=== Modifica

    Const sEmailContatto As String = _

    "provachiocciola.hotmail.com" '<<=== Modifica

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

    LRow = LastRow(SH, .Columns("A:A"))

    Set Rng = .Range("A2:J" & LRow)

    End With

    arrIn = Rng.Value2

    Set oOutlook = CreateObject("Outlook.Application")

    For i = 1 To UBound(arrIn)

    Set oMail = oOutlook.CreateItem(0)

    With oMail

    sIndirizzo = arrIn(i, 1)

    sCognome = arrIn(i, 2)

    sNome = arrIn(i, 3)

    sTitolo = arrIn(i, 4)

    sPercorso = arrIn(i, 5)

    sAllegato = arrIn(i, 6)

    sAllegato2 = arrIn(i, 7)

    sAllegato3 = arrIn(i, 8)

    sAllegato3 = arrIn(i, 9)

    sAllegato3 = arrIn(i, 10)

    sbody = "<H3><B>Gentile " & sNome & " " _

    & sCognome & ",</B></H3>" & _

    "la tua iscrizione al corso XXYY di Volley del " & _

    "25 febbraio 2018" & _

    " presso l'istituto ZZKK sito in via Padova, 40 a Milano" & _

    " è stata registrata." & _

    "<br><br>Per confermare l'iscrizione è necessario effettuare" & _

    " il pagamento entro e non oltre domenica 18 febbraio 2018." & _

    "<br><br>Per qualsiasi chiarimento o dubbio, contatta " & _

    "la Segreteria allo 02/xxxxxxxx o scrivi a:" & Space(1) & _

    " <B>" & sEmailContatto & "</B>" & _

    "<br><br>Cordiali saluti<br>" & _

    "<br><B>Cognome nome</B><br>" & _

    "Segreteria di direzione" & _

    "<br>Nome Azienda<br>" & _

    "N°telefono<br>" & _

    "sito web<br>" & _

    "indirizzo mail<br>"

    .display

    .To = sIndirizzo

    .CC = ""

    .BCC = ""

    .Subject = sOggetto

    .HTMLBody = sbody & "<br>" & .HTMLBody

    .Attachments.Add sPercorso _

    & Application.PathSeparator _

    & sAllegato & sAllegato2 & sAllegato3 & sAllegato4 & sAllegato5

    .display 'Send

    End With

    Set oMail = Nothing

    Next i

    Set oMail = Nothing

    Set oOutlook = Nothing

    End Sub

    Prova invece qualcosa del genere:

    '========>>

    Option Explicit

    '-------->>

    Public Sub Tester() 

    Dim WB As Workbook 

Dim SH As Worksheet 

Dim Rng As Range 

Dim arrIn As Variant 

Dim oOutlook As Object 

Dim oMail As Object 

Dim sIndirizzo As String 

Dim sNome As String 

Dim sCognome As String 

Dim sTitolo As String 

Dim sPercorso As String 

Dim sAllegato As String, sAllegato2 As String 

Dim sAllegato3 As String, sAllegato4 As String, sAllegato5 As String 

Dim sbody As String 

Dim LRow As Long, i As Long 

Const sFoglio As String = **"Foglio1"                      '&lt;&lt;=== Modifica** 

Const sOggetto As String = **"Vote for Trump"     '&lt;&lt;=== Modifica** 

Const sEmailContatto As String = **"provachiocciola.hotmail.com"         '&lt;&lt;=== Modifica** 

Set WB = ThisWorkbook 

Set SH = WB.Sheets(sFoglio)  

With SH 

    LRow = LastRow(SH, .Columns("A:A")) 

    Set Rng = .Range("A2:J" & LRow) 

End With 

arrIn = Rng.Value2 

Set oOutlook = CreateObject("Outlook.Application") 

For i = 1 To UBound(arrIn) 

    Set oMail = oOutlook.CreateItem(0) 

    With oMail 

        sIndirizzo = arrIn(i, 1) 

        sCognome = arrIn(i, 2) 

        sNome = arrIn(i, 3) 

        sTitolo = arrIn(i, 4) 

        sPercorso = arrIn(i, 5) 

        sAllegato = arrIn(i, 6) 

        sAllegato2 = arrIn(i, 7) 

        sAllegato3 = arrIn(i, 8) 

        sAllegato4 = arrIn(i, 9) 

        sAllegato5 = arrIn(i, 10) 

        sbody = "&lt;H3&gt;&lt;B&gt;Gentile " & sNome & " " \_ 

                & sCognome & ",&lt;/B&gt;&lt;/H3&gt;" & \_ 

                "la tua iscrizione al corso XXYY di Volley del  " & \_ 

                "25 febbraio 2018" & \_ 

                " presso l'istituto ZZKK sito in via Padova, 40 a Milano" & \_ 

                " è stata registrata." & \_ 

                "&lt;br&gt;&lt;br&gt;Per confermare l'iscrizione è necessario effettuare" & \_ 

                " il pagamento entro e non oltre domenica 18 febbraio 2018." & \_ 

                "&lt;br&gt;&lt;br&gt;Per qualsiasi chiarimento o dubbio, contatta " & \_ 

                "la Segreteria allo 02/xxxxxxxx o scrivi a:" & Space(1) & \_ 

                " &lt;B&gt;" & sEmailContatto & "&lt;/B&gt;" & \_ 

                "&lt;br&gt;&lt;br&gt;Cordiali saluti&lt;br&gt;" & \_ 

                "&lt;br&gt;&lt;B&gt;Cognome  nome&lt;/B&gt;&lt;br&gt;" & \_ 

                "Segreteria di direzione" & \_ 

                "&lt;br&gt;Nome Azienda&lt;br&gt;" & \_ 

                "N°telefono&lt;br&gt;" & \_ 

                "sito web&lt;br&gt;" & \_ 

                "indirizzo mail&lt;br&gt;" 

        .To = sIndirizzo 

        .CC = "" 

        .BCC = "" 

        .Subject = sOggetto 

        .HTMLBody = sbody & "&lt;br&gt;" & .HTMLBody 

        .Attachments.Add sPercorso \_ 

                         & Application.PathSeparator \_ 

                         & sAllegato 

        .Attachments.Add sPercorso \_ 

                         & Application.PathSeparator \_ 

                         & sAllegato2 

        .Attachments.Add sPercorso \_ 

                         & Application.PathSeparator \_ 

                         & sAllegato3 

        .Attachments.Add sPercorso \_ 

                         & Application.PathSeparator \_ 

                         & sAllegato4 

        .Attachments.Add sPercorso \_ 

                         & Application.PathSeparator \_ 

                         & sAllegato5 

        .display    'Send 

    End With 

    Set oMail = Nothing 

Next i 

Set oMail = Nothing 

Set oOutlook = Nothing

    End Sub

    '--------->>

    Public Function LastRow(SH As Worksheet, _ 

    Optional Rng As Range, \_ 

Optional minRow As Long = 1) 

If Rng Is Nothing Then 

    Set Rng = SH.Cells 

End If 

On Error Resume Next 

LastRow = Rng.Find(What:="\*", \_ 

    After:=Rng.Cells(1), \_ 

    Lookat:=xlPart, \_ 

    LookIn:=xlFormulas, \_ 

    SearchOrder:=xlByRows, \_ 

    SearchDirection:=xlPrevious, \_ 

    MatchCase:=False).Row 

On Error GoTo 0 

If LastRow &lt; minRow Then 

    LastRow = minRow 

End If

    End Function

    '<<========

    ===

    Regards,

    Norman

    Immagine

    La risposta è stata utile?

    0 commenti