Invio email automatico con excel

Question

Ciao a tutti,

so che la questione è stata affrontata molte volte e sotto diversi aspetti ma vorrei comunque una delucidazione.

Ogni mattina vengono elaborati dei report tramite fogli excel già preimpostati. I report vengono generati con delle macro e salvati sempre allo stesso percorso, pronti per essere inviati ad una serie di destinatari, anche in CC e CCN, con testo del messaggio e oggetto pressoché standard.

Quello che mi chiedo è da dove partire, cioè con quale pezzo di codice iniziare a fare delle prove per risolvere le mie esigenze. 

Lo step ultimo sarà far generare i report, buttarli in archivio, allegarne copia via mail tutto con un solo tasto. Ma un passo alla volta :)

Answer 1

Ciao Francesco,

è esattamente così che intendevo!

Perché in questo modo potrei costruire nelle varie celle, in automatico con varie funzioni, i nomi giornalieri dei file e del corpo del messaggio.

A quel punto mi basterebbe aprire il file e lanciare la/le macro!

Cancella il codice precedente e prova qualcosa del genere:

Alt-F11 per aprire l'editor di VBA

Alt-IMper inserire un nuovo modulo di codice

Nel nuovo modulo vuoto, incolla il seguente codice:

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

Option Explicit

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

Public InviareReport()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, Rng2 As Range

    Dim RngAttachments As Range, RngDestinari As Range

    Dim RngCC As Range, RngCCN As Range, RngOggetto As Range

    Dim RngCorpo As Range, RngAllegati As Range

    Dim aCell As Range, rCell As Range

    Dim arrNotFound() As Variant

    Dim LRow As Long, aRow As Long, bRow As Long

    Dim iRows As Long, i As Long

    Dim CalcMode As Long

    Dim arrCC As Variant, arrCCN As Variant, arrAllegati As Variant

    Dim sDestinari As String, sCC As String, sCCN As String

    Dim sOggetto As String, sCorpo As String, sAllegati As String

    Dim sStr As String, sMissing As String

    Dim bFound As Boolean

    Const sSheetName As String = "Controller"                                 '<<==== Modifica

    Const sPercorso As String = "**C:\Pippo\MyReports**"                   '<<==== Modifica

    On Error GoTo ErrHandler

    Set WB = ActiveWorkbook

    Set SH = WB.Sheets(sSheetName)

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    With SH

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

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

    End With

    On Error Resume Next

    With Rng.Columns(6)

        Set RngAttachments = Intersect(.Item(1), .SpecialCells(xlConstants))

    End With

    On Error GoTo ErrHandler

    If Not RngAttachments Is Nothing Then

        For Each aCell In RngAttachments.Cells

            sStr = aCell.Value

            bFound = Dir(sPercorso & sStr) <> vbNullString

            If Not bFound Then

                i = i + 1

                ReDim arrNotFound(i To i)

                arrNotFound(i) = sStr

            End If

        Next aCell

    Else

        sMissing = "Nessun allegato trovato"

    End If

    If CBool(i) Then

        sMissing = "I seguenti allegati non sono stati trovati" _

                   & vbNewLine & vbNewLine _

                   & Join(arrNotFound, vbNewLine)

    End If

    If sMissing <> vbNullString Then

        Call MsgBox(prompt:=sMissing, _

                    Buttons:=vbCritical, _

                    Title:="Report NON inviati!")

        GoTo XIT

    End If

    On Error Resume Next

    Set Rng2 = Rng.SpecialCells(xlConstants)

    On Error GoTo 0

    If Not Rng Is Nothing Then

        For Each rCell In Rng2.Cells

            With rCell

                sDestinari = .Value

                aRow = .Row

                If IsEmpty(.Offset(1)) Then

                    bRow = .End(xlDown).Row

                Else

                    bRow = aRow

                End If

                iRows = bRow - aRow

                Set Rng2 = .Resize(iRows, 6)

            End With

            On Error Resume Next

            With Rng2

                Set RngDestinari = .Cells(1, 1)

                With .Columns(2)

                    Set RngCC = Intersect(.Item(1), .SpecialCells(xlConstants))

                End With

                With .Columns(3)

                    Set RngCCN = Intersect(.Item(1), .SpecialCells(xlConstants))

                End With

                Set RngOggetto = .Cells(1, 4)

                Set RngCorpo = .Cells(1, 5)

                With .Columns(6)

                    Set RngAllegati = Intersect(.Item(1), .SpecialCells(xlConstants))

                End With

            End With

            Err.Clear

            On Error GoTo ErrHandler

            sDestinari = RngDestinari.Value

            sOggetto = RngOggetto.Value

            sCorpo = RngCorpo.Value

            If Not RngCC Is Nothing Then

                arrCC = Application.Transpose(RngCC.Value)

                ReDim Preserve arrCC(1 To RngCC.Cells.Count)

                If IsArray(arrCC) Then

                    sCC = Join(arrCC, ",")

                Else

                    sCC = RngCC.Value

                End If

            End If

            If Not RngCCN Is Nothing Then

                arrCCN = Application.Transpose(RngCCN.Value)

                ReDim Preserve arrCC(1 To RngCCN.Cells.Count)

                If IsArray(arrCCN) Then

                    sCCN = Join(arrCCN, ",")

                Else

                    sCCN = RngCCN.Value

                End If

            End If

            If Not RngAllegati Is Nothing Then

                arrAllegati = Application.Transpose(RngAllegati.Value)

                ReDim Preserve arrCC(1 To RngAllegati.Cells.Count)

                If IsArray(arrAllegati) Then

                    sAllegati = Join(arrAllegati, ",")

                Else

                    sAllegati = RngAllegati.Value

                End If

            End If

            Call EmailReport(sPercorso, _

                             sDestinari, _

                             sCC, _

                             sCCN, _

                             sOggetto, _

                             sCorpo, _

                             arrAllegati)

        Next rCell

    End If

    Call MsgBox(prompt:="Tutti i report sono stati inviati", _

                Buttons:=vbInformation, _

                Title:="Finito")

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

    On Error GoTo 0

    Exit Sub

ErrHandler:

    Call MsgBox(prompt:="Error " _

                        & Err.Number _

                        & " (" _

                        & Err.Description _

                        & ") nella routine: InviareReport", _

                Buttons:=vbCritical, _

                Title:="ERRORE")

    Resume XIT

End Sub

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

Function LastRow(SH As Worksheet, _

                 Optional Rng As Range)

    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

End Function

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

Public Function EmailReport(aPath As String, _

                            strDestinari As String, _

                            strCC As String, _

                            strCCN As String, _

                            strOggetto As String, _

                            strCorpo As String, _

                            arrAllegati As Variant) '

    Dim oOutApp As Object

    Dim oOutMail As Object

    Dim i As Long, j As Long

    Dim sMsg As String, aMsg As String, sStr As String

    Dim sPath As String, sFullname As String

    On Error GoTo ErrHandler

    If Right(aPath, 1) <> Application.PathSeparator Then

        sPath = aPath & Application.PathSeparator

    Else

        sPath = aPath

    End If

    With Application

        .EnableEvents = False

        .ScreenUpdating = False

    End With

    Application.StatusBar = "Inviando Email ... "

    Set oOutApp = CreateObject("Outlook.Application")

    Set oOutMail = oOutApp.CreateItem(0)

    With oOutMail

        .To = strDestinari

        .cc = strCC

        .BCC = strCCN

        .Subject = strOggetto

        .Body = strCorpo

        If IsArray(arrAllegati) Then

            For i = 1 To UBound(arrAllegati)

                .Attachments.Add (aPath & arrAllegati(i))

            Next i

        Else

            .Attachments.Add (aPath & arrAllegati)

        End If

        ' .Send

        .Display

    End With

XIT:

    Set oOutMail = Nothing

    Set oOutApp = Nothing

    With Application

        .EnableEvents = True

        .ScreenUpdating = True

        .StatusBar = False

    End With

    On Error GoTo 0

    Exit Function

ErrHandler:

    Call MsgBox(prompt:="Errore " _

                        & Err.Number _

                        & " (" _

                        & Err.Description _

                        & ") nella routine: EmailReport", _

                Buttons:=vbCritical, _

                Title:="ERRORE")

    Resume XIT

End Function

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

Alt-Q per chiudere l'editor di VBA e tornare a Excel.

Alt-F8 per aprire la finestrina macro

Seleziona InviareReport | Esegui

Se dovessi riscontrare un messaggio di errore, sostituisci temporaneamente la prima riga della macro  InviareReport:

                On Error GoTo ErrHandler

con

                **'**On Error GoTo ErrHandler        [Nota l'apostrofo iniziale]

Quindi esegui nuovamente il codice e communica  la riga di codice che viene evidenziata, insieme al numero di errore e il messaggio di errore, in una risposta qui. Quando il test è completo, cancella questo apostrofo.

Ai fini del test, le email verranno visualizzate anziché inviate. Quando il test è completo, nella funzione EmailReport sostituisci:

       ' .Send

        .Display

    End With

con

        .Send

    End With

===

Regards,

Norman

Answer 2

Ciao Francesco,

Non ho ancora avuto modo di provare la tua macro, ma leggendo mi è venuto un pensiero: deve essere copia-incollata ogni volta nel report generato, giusto?

No, questo non è necessario. Sarebbe possibile incollare il codice in un file che sarà aperto quando si crea il rapporto giornaliero. Questo file potrebbe essere, ad esempio, la cartella di lavoro che si utilizza per manipolare i rapporti o, in alternativa, il tuo file Personal.xls,  che è nascosto ed è sempre aperto.

[CUT]

===

Regards,

Norman

Ciao Norman,

ahimé neanche oggi mi è riuscito di provare la tua macro :(

La soluzione che prende gli indirizzi da una lista di outlook va benissimo poiché se mi toccherà modificare l'elenco andrò sempre a modificare quel gruppo.

Quello che non mi è chiaro è dove incollare il codice e come fargli puntare ai file che mi interessano di volta in volta.

Metti che ho 3 report diversi da inviare a 3 liste diverse.

Dovrò crearmi tanti "fogli di invio" da aprire di volta in volta per mandare il tutto?

Perdonami, magari provando la macro la cosa viene automatica ma non mi è stato ancora possibile.

Ad ogni modo grazie infinite.

Francesco

Answer 3

Ciao Francesco,

Non ho ancora avuto modo di provare la tua macro, ma leggendo mi è venuto un pensiero: deve essere copia-incollata ogni volta nel report generato, giusto?

No, questo non è necessario. Sarebbe possibile incollare il codice in un file che sarà aperto quando si crea il rapporto giornaliero. Questo file potrebbe essere, ad esempio, la cartella di lavoro che si utilizza per manipolare i rapporti o, in alternativa, il tuo file Personal.xls,  che è nascosto ed è sempre aperto.

Approfitto per precisare che invece di utilizzare il 'gruppo' di Outlook di cui ho parlato, si potrebbe utilizzare un elenco di indirizzi email in una colonna di una cartella di lavoro dedicato, ad esempio, un file denominato IndirizziEmail.xlsx. Se preferiresti questo approccio, modificherò il codice suggerito

===

Regards,

Norman

Answer 4

Ciao Francesco,

Suggerisco che tu crei un 'gruppo e-mail' in Outlook, elencando nel gruppo tutti i destinatari giornalieri per i report. Supponiamo che questo gruppo si chiami GruppoReport. 

[CUT]

Regards,

Norman

Ciao Norman,

grazie per la risposta!

Non ho ancora avuto modo di provare la tua macro, ma leggendo mi è venuto un pensiero: deve essere copia-incollata ogni volta nel report generato, giusto?

Answer 5

Ciao Francesco,

Suggerisco che tu crei un 'gruppo e-mail' in Outlook, elencando nel gruppo tutti i destinatari giornalieri per i report. Supponiamo che questo gruppo si chiami GruppoReport. 

Ogni giorno potresti salvare la cartella di lavoro e, con la cartella di lavoro aperta, utilizzare qualcosa del genere:

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 Sub Tester()

    With ActiveWorkbook

        Call EmailReport(.FullName, .Name, "GruppoRepor t") 

    End With

End Sub

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

Public Function EmailReport(myFile As String, _

                           sFilename As String, _

                           ParamArray myRecipients() As Variant)

    Dim oOutApp As Object

    Dim oOutMail As Object

    Dim i As Long

    Dim sMsg As String, aMsg As String, sStr As String

    On Error GoTo ErrHandler

    sMsg = "Buongiorno! Allego il report " _

           & sFilename & " per oggi: " _

           & Format(Date, "dddd dd mmmm, yyyy")            '<<==== Modifica il messagio

    With Application

        .EnableEvents = False

        .ScreenUpdating = False

    End With

    Set oOutApp = CreateObject("Outlook.Application")

    Set oOutMail = oOutApp.CreateItem(olMailItem)

    For i = LBound(myRecipients) To UBound(myRecipients)

        Set oOutMail = oOutApp.CreateItem(olMailItem)

        With oOutMail

            .To = myRecipients(i)

            .Subject = "Mio Report"                                   '<<==== Modifica  

            .Body = sMsg

            .Attachments.Add myFile

            '.Send

            .Display

        End With

        Set oOutMail = Nothing

    Next i

XIT:

    Set oOutMail = Nothing

    Set oOutApp = Nothing

    With Application

        .EnableEvents = True

        .ScreenUpdating = True

    End With

    On Error GoTo 0

    Exit Function

ErrHandler:

    Call MsgBox(Prompt:="Errore " _

                        & Err.Number _

                        & " (" _

                        & Err.Description _

                        & ") nella routine: Tester", _

                Buttons:=vbCritical, _

                Title:="ERRORE")

    Resume XIT

End Function

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

Alt-Q per chiudere l'editor di VBA e tornare a Excel.

Alt-F8 per aprire la finestrina macro

Seleziona Tester | Esegui

Se, un giorno, dovresti avere la necessità di aggiungere altri destinatari, nella macro Tester, potresti sostituire la riga:

        Call EmailReport(.FullName, .Name, "GruppoReport") 

con qualcosa del tipo:

        Call EmailReport(.FullName, .Name, "GruppoReport", _

                         "AngelaCHIOCCIOLAhotmailPUNTOcom", _

                         "BenjaminoCHIOCCIOLAgmailPUNTOcom")

Se lo desiderassi, invece di utilizzare la macro Tester, potresti avviare la procedura EmailReport direttamente dal codice che salva e archivia il file quotidiano.

===

Regards,

Norman