Invio multimail con protocollo MAPI

Question

Buongiorno a tutti,  è da pochi giorni che la mia Agenzia lavorativa ha cambiato il protocollo di posta elettronica da CDO_SMTP A MAPI.

Avevo creato all'epoca il codice sottoriportato che mi pemetteva di inviare in modo automatico  le e-mails a tanti destinatari con file allegati tramite dei dati riportati in un foglio di Excel, cosi come si evince nel codice stesso.

Ho bisogno del vostro aiuto per poter adattare il codice in argomento al nuovo protocollo MAPI poiché il file di Excel non  lo posso più utilizzare.

Ringrazio anticipatamente chi mi aiuta in questo.

Sub invia_email_CDO_SMTP()

Dim rr As long

Sheets("Foglio1").Select

rr = Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To rr

Set mess = CreateObject("CDO.Message")

Set Config = CreateObject("CDO.Configuration")

Config.Load -1

Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _

= "xxxxxxxxxxxxx" 'metti qui il tuo server smtp

Config.Fields.Update

With mess

Set .Configuration = Config

.To = Cells(i, 2) 

.CC = Cells(i, 3)

.BCC = ""

.From = Cells(i, 5)

.Subject = Cells(i, 4) 'Range("oggetto").Value

.TextBody =

.AddAttachment = Cells(i, 6) & Cells(i, 7)

.Send

End With

On Error GoTo ERRORE

Cells(i, 15) = "INVIATA"

Set mess = Nothing

Set Config = Nothing

Next i

ERRORE:

Cells(i, 16) = "ERRORE, NON INVIATA"

MsgBox ("La mail non è stata inviata al:") & Cells(i, 2).Value

Application.ScreenUpdating = True

Resume Next

MsgBox ("Invio multimail completato")

End Sub

Ciao!

Nicola.

Answer 1

Ciao Nicola,

Ho fatto varie prove e il tuo codice funziona benissimo, ti chiedo l'ultima cortesia.

E' possibile poter allegare il/i file/files a tutti i destinatari scegliendolo con Filedialog senza dover riportare in una cella il percorso ecc.

Prova a sosituire il codice nel modulo standard con la seguente versione nella quale le modifiche sono evidenziate in grassetto:

'=========>>

Option Explicit

Public currWatcher As clsEmailWatcher

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

Public Sub Invia_Email()

'\ Inserisci un riferimento alla libreria Outlook xx.x Object Library

'\ Alt+F11 Strumenti | Riferimenti

    Dim oOutlook As Outlook.Application  ' Object

    Dim oMail As Outlook.MailItem

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, rCell As Range

Dim FD As FileDialog

Dim vSelectedItem As Variant

Dim arrAllegati As Variant

    Dim sDestinario As String

    Dim sCopia As String

    Dim sOggetto As String

    Dim sMittente As String

    Dim sMsg As String

    Dim bSend As Boolean

    Dim i As Long, j As Long, Ctr As Long

    Dim LRow As Long

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

    Set oOutlook = CreateObject("Outlook.Application")

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

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

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

    End With

Set FD = Application.FileDialog(msoFileDialogOpen)

With FD

.AllowMultiSelect = True

.Title = "Seleziona file da allegare"

.Filters.Clear

.Filters.Add "Excel", "*.xls?"

.InitialView = msoFileDialogViewDetails

If .Show = True Then

ReDim arrAllegati(1 To .SelectedItems.Count)

For Each vSelectedItem In .SelectedItems

j = j + 1

arrAllegati(j) = .SelectedItems(j)

Next vSelectedItem

End If

End With

    For Each rCell In Rng.Cells

        With rCell

            sDestinario = .Offset(0, 1).Value

            sCopia = .Offset(0, 2).Value

            sOggetto = .Offset(0, 3).Value

            sMittente = .Offset(0, 4).Value

          End With

        If sDestinario Like "?*@?*.?*" Then

            Set oMail = oOutlook.CreateItem(0)

            Set currWatcher = New clsEmailWatcher

            Set currWatcher.BoolRange = rCell.Offset(0, 6)

            Set currWatcher.DateRange = rCell.Offset(0, 7)

            Set currWatcher.TheMail = oMail

            On Error Resume Next

            With oMail

                .To = sDestinario

                .CC = sCopia

                .BCC = ""

                .Subject = sOggetto

                .Body = ""

For j = 1 To UBound(arrAllegati)

.Attachments.Add arrAllegati(j)

Next j

                  .Send

            End With

        End If

        On Error GoTo 0

        Set oMail = Nothing

    Next rCell

    Call MsgBox( _

         Prompt:="Invio multimail completato", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    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

Answer 2

Infinite grazie Norman, come sempre gentilissimo e professionale.

Va benissimo così.

Alla prossima richiesta di aiuto.

Ciao Nicola

Answer 3

Ciao Norman, grazie come sempre per la tua professionalità ed il tuo cortese intervento.

Ho fatto varie prove e il tuo codice funziona benissimo, ti chiedo l'ultima cortesia.

E' possibile poter allegare il/i file/files a tutti i destinatari scegliendolo con Filedialog senza dover riportare in una cella il percorso ecc.

Ciao!

Nicola.

Answer 4

Ciao Nicola,

Buongiorno a tutti,  è da pochi giorni che la mia Agenzia lavorativa ha cambiato il protocollo di posta elettronica da CDO_SMTP A MAPI.

Avevo creato all'epoca il codice sottoriportato che mi pemetteva di inviare in modo automatico  le e-mails a tanti destinatari con file allegati tramite dei dati riportati in un foglio di Excel, cosi come si evince nel codice stesso.

Ho bisogno del vostro aiuto per poter adattare il codice in argomento al nuovo protocollo MAPI poiché il file di Excel non  lo posso più utilizzare.

Ringrazio anticipatamente chi mi aiuta in questo.

Sub invia_email_CDO_SMTP()

Dim rr As long

Sheets("Foglio1").Select

rr = Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To rr

Set mess = CreateObject("CDO.Message")

Set Config = CreateObject("CDO.Configuration")

Config.Load -1

Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

Config.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _

= "xxxxxxxxxxxxx" 'metti qui il tuo server smtp

Config.Fields.Update

With mess

Set .Configuration = Config

.To = Cells(i, 2) 

.CC = Cells(i, 3)

.BCC = ""

.From = Cells(i, 5)

.Subject = Cells(i, 4) 'Range("oggetto").Value

.TextBody =

.AddAttachment = Cells(i, 6) & Cells(i, 7)

.Send

End With

On Error GoTo ERRORE

Cells(i, 15) = "INVIATA"

Set mess = Nothing

Set Config = Nothing

Next i

ERRORE:

Cells(i, 16) = "ERRORE, NON INVIATA"

MsgBox ("La mail non è stata inviata al:") & Cells(i, 2).Value

Application.ScreenUpdating = True

Resume Next

MsgBox ("Invio multimail completato")

End Sub

• Alt+F11 per aprire l'editor di VBA
• Alt+IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

'=========>>

Option Explicit

Public currWatcher As clsEmailWatcher

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

Public Sub Invia_Email()

    '\ Inserisci un riferimento alla libreria Outlook xx.x Object Library

    '\ Alt+F11 | Strumenti | Riferimenti

    Dim oOutlook As Outlook.Application

    Dim oMail As Outlook.MailItem

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, rCell As Range

    Dim sDestinario As String

    Dim sCopia As String

    Dim sOggetto As String

    Dim sAllegato As String

    Dim sMittente As String

    Dim sMsg As String

    Dim bSend As Boolean

    Dim i As Long, iCtr As Long

    Dim LRow As Long

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

    Set oOutlook = CreateObject("Outlook.Application")

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

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

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

    End With

    For Each rCell In Rng.Cells

        With rCell

            sDestinario = .Offset(0, 1).Value

            sCopia = .Offset(0, 2).Value

            sOggetto = .Offset(0, 3).Value

            sMittente = .Offset(0, 4).Value

            sAllegato = .Offset(0, 5).Value & .Offset(0, 6).Value

        End With

        If sDestinario Like "?*@?*.?*" Then

            Set oMail = oOutlook.CreateItem(0)

            Set currWatcher = New clsEmailWatcher

            Set currWatcher.BoolRange = rCell.Offset(0, 15)

            Set currWatcher.DateRange = rCell.Offset(0, 16)

            Set currWatcher.TheMail = oMail

            On Error Resume Next

            With oMail

                .To = sDestinario

                .CC = sCopia

                .BCC = ""

                .Subject = sOggetto

                .Body = ""

                .Attachments.Add sAllegato

                .Send

            End With

        End If

        On Error GoTo 0

        Set oMail = Nothing

    Next rCell

    Call MsgBox( _

         Prompt:="Invio multimail completato", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    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

'<<=========

• Alt+F11 per aprire l'editor di VBA
• Alt+ICper inserire un nuovo modulo Classe
• Nel nuovo modulo vuoto, incolla il seguente codice:

'=========>>

Option Explicit

Public BoolRange As Range

Public DateRange As Range

Public WithEvents TheMail As Outlook.MailItem

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

Private Sub TheMail_Send(Cancel As Boolean)

    If Not BoolRange Is Nothing Then

        BoolRange.Value = True

    End If

    If Not DateRange Is Nothing Then

        DateRange.Value = Now()

    End If

End Sub

'<<=========

• F4 per aprire la finestra delle proprietà per il modulo class e rinominarlo clsEmailWatcher

                        

• Fai clic su X per chiudere la finestra delle proprietà
• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm

===

Regards,

Norman