Macro invio mail con allegati differenti

Question

Buongiorno e grazie a chi mi vorrà rispondere. Mi sto cimentando con le macro ma sono un novizio senza grandi conoscenze, quindi faccio casino!!

Devo creare delle mail standard con vari campi che variano al variare del record (come di seguito), con allegato un file che varia in base al campo C2, cioè sono presenti in una cartellina tutti i file nominati come il campo C2.

Spett.le

(contenuto campo H2)

(contenuto campo J2)

(contenuto campo K2) (contenuto campo L2)

c.a. (contenuto I2)

(contenuto S2),

Ti trasmetto il questionario per la rilevazione dei dati utili alla redazione della aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.

Come in precedenza potrai compilarlo a mano e rinviarlo via fax, oppure compilarlo, salvarlo e inviarlo via email; lo stesso questionario è scaricabile collegandoTi all’indirizzo (contenuto T2)

Fiducioso di poter continuare a contare sulla Tua collaborazione, attendo le risposte e Ti saluto cordialmente

Alessandro

Allegato file (contenuto C2) 

Ho modificato una MACRO che ho trovato in una discussione, così:

Sub Invioemail()

    Dim OutApp As Object

    Dim OutMail As Object

    Dim EmailAddr As String

    Dim Subj As String

    Dim BodyText As String                      'FIN QUI E' SONO "DICHIARAZIONI"

    '  (a)

    Set OutApp = CreateObject("Outlook.Application")

    ''compilazione di un testo standard di accompagnamento   'LA VARIABIE BDT VIENE COMPILATA CON UN TESTO STANDARD

    BDT = "Ti trasmetto il questionario per la rilevazione dei dati utili alla redazione della Nota  del I semestre 2015 rispetto al 2014."

    BDT = BDT & vbCrLf & "Cordiali saluti" & vbCrLf

    BDT = BDT & "Rea"

    ''  (b)

    Codic = Sheets("CAMPIONE").Range("C2").Value       'E' IL NOME DESTINATARIO, A TE NON SERVE

    OutFile = "Z:\Protocollo 2015\Centro Studi\Nota Congiunturale I sem 2015\Questionari\Autotrasporto" & Codic & ".xlsx"     'NOME DEL FILE ALLEGATO; 

    EmailAddr = Range("M2").Value      'INDIRIZZO EMAIL, PRESO DA h5 DEL FOGLIO CORRENTE

    Subj = "Nota I Sem. 2015"    'OGGETTO DELLA MAIL

    '

    Set OutMail = OutApp.CreateItem(0)     'DA QUI SI CREA E INVIA LA MAIL

    With OutMail

    .To = EmailAddr

    .CC = ""

    .BCC = ""

    .Subject = Subj

    .Attachments.Add OutFile

    .Body = BDT

    .Display 'or use .send

    '.send

    End With

    '  (c)

    Set OutMail = Nothing

    '

    '  (d)

    Set OutApp = Nothing

        Application.Wait (Now + TimeValue("0:00:04"))

        Application.SendKeys "%a"

        Application.Wait (Now + TimeValue("0:00:04"))

    '

    'Rename Image files

    'Name "C:\ESITI" & Nominat & "_ScrSh.jpg" As "C:\ESITITX\ " & Nominat & "_ScrSh.jpg"

    End Sub

Funziona ma:

1. manda solo il primo record, ho fatto una prova con due record e due mail differenti mi prepara all'invio del primo e basta
2. come si mette un testo più lungo, che vada a capo e con pezzi da prendere nelle celle come riportato sopra?
3. è possibile inviare la stessa mail a più destinatari? il secondo in copia (contenuto N2)?

Grazie infinite a chi mi vorrà dedicare qualche minuto del suo tempo

Alessandro

Answer 1

Ciao Alessandro,

Ti ringrazio per il cortese riscontro.

Per chiudere questo thread, vorrei gentilmente chiederti di contrassegnare la mia risposta come Risposta. In questo modo, tu aiuterai anche coloro che potrebbero cercare soluzioni ai problemi simili negli archivi della comunità.

Alla prossima.

===

Regards,

Norman

Answer 2

Ciao Norman,

avevo già provveduto a modificare dei dettagli per rendere la mail uguale a quella inviata nelle precedenti richieste. Ora è veramente perfetta!! Ti ringrazio infinitamente!!

Alessandro

Answer 3

Ciao Alessandro,

A proposito, avrei dovuto anche indicare esplicitamente che, nella riga All'Attenzione di: delle email**,**avevo messo il nome del destinatario in blu grassetto per accordarsi con il mio gusto personale. Se questo non fosse a tuo gradimento, potrei modificarlo,

===

Regards,

Norman

Answer 4

Ciao Alessandro,

grazie infinite! Il messaggio è perfetto. Ultime due domande:

1. leggevo l'intervallo         Set RngTabella = .Range("A2:L" & LRow)

  ma la MACRO funziona con tutte le righe che compilo del foglio non si ferma alla L, vero?

La mia macro definisce l'intervallo di interesse come quell'intervallo che sia compreso tra la riga 2 e l'ultima riga popolata nella colonna A; questo intervallo venga poi ulteriormente limitato a comprendere solo le colonne A: L. Questo intervallo include tutti i dati e, di conseguenza, non capisco la sua preoccupazione.

2. La grafica ora è perfetta manca solo una cosa, mi scrive Spett.le in Times New Roman 12 e non in Calibri 10 come è scritto tutto il resto del messaggio. Si può cambiare? Ho provato anche a inserirlo come campo arrTabella(i, 2) _ nel foglio di lavoro in una cella accanto ma continua con lo stesso font.

Sostituisci il codice precedente con la segente versione:

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

Option Explicit

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

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim RngTabella As Range

    Dim arrTabella As Variant

    Dim OutApp As Object

    Dim OutMail As Object

    Dim sHeader As String, sMsg As String, sFile As String

    Dim sPath As String, sStr As String

    Dim sBody As String

    Dim LRow As Long, i As Long, j As Long

    Const sSoggetto As String = "Cartelle in scadenza"

    Const sGreeting As String = "All'attenzione di:"

    Const sPercorso As String = "Z:\Protocollo 2015\Centro \Nota \Lettere"

    Set WB = ThisWorkbook

    Set SH = WB.Sheets("Campione")

    With SH

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

        Set RngTabella = .Range("A2:L" & LRow)

    End With

    arrTabella = RngTabella.Value

    On Error GoTo 0

    With Application

        sStr = .PathSeparator

        .EnableEvents = False

        .ScreenUpdating = False

    End With

    If Right(sPercorso, 1) = sStr Then

        sPath = sPercorso

    Else

        sPath = sPercorso & sStr

    End If

    For i = 1 To UBound(arrTabella, 1)

        sFile = arrTabella(i, 3) & ".xlsx"

        sHeader = "<font face=""Calibri"" size=""2"">Spett.le</font>" _

                & "<br>" _

                & arrTabella(i, 4) _

                & "<br>" _

                & arrTabella(i, 6) _

                & "<br>" _

                & arrTabella(i, 7) _

                & "<br>" _

                & arrTabella(i, 8) _

                & "<br>" & "<br>" _

                & sGreeting _

                & "<font color=""blue""><b>" _

                & arrTabella(i, 5) _

                & "</b></font><br><br>"

        sMsg = arrTabella(i, 11) _

             & "<br><br>" _

             & "Ti trasmetto il questionario per la rilevazione " _

             & "dei dati utili alla redazione della ????." _

             & "<br><br>" _

             & "Come in precedenza potrai compilarlo a mano e rinviarlo " _

             & "via fax, oppure compilarlo, salvarlo e inviarlo via email; " _

             & "lo stesso questionario è scaricabile collegandoTi all’indirizzo " _

             & arrTabella(i, 12) _

             & "<br><br>" _

             & "Fiducioso di poter continuare a contare sulla Tua " _

             & "collaborazione, attendo le risposte e Ti saluto cordialmente" _

             & "<br><br>" _

             & "Allegato: " & sFile

        sBody = sHeader & "<br>" & sMsg

        Set OutApp = CreateObject("Outlook.Application")

        Set OutMail = OutApp.CreateItem(0)

        On Error Resume Next

        With OutMail

            .Display

            .To = arrTabella(i, 9)

            .CC = arrTabella(i, 10)

            .BCC = ""

            .Subject = sSoggetto

            .Attachments.Add sPath & sFile

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

            .Send

        End With

        Set OutMail = Nothing

    Next i

    On Error GoTo 0

    Set OutMail = Nothing

    Set OutApp = Nothing

End Sub

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

Public 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

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

===

Regards,

Norman

Answer 5

Ciao Norman,

grazie infinite! Il messaggio è perfetto. Ultime due domande:

1. leggevo l'intervallo         Set RngTabella = .Range("A2:L" & LRow)

  ma la MACRO funziona con tutte le righe che compilo del foglio non si ferma alla L, vero?

2. La grafica ora è perfetta manca solo una cosa, mi scrive Spett.le in Times New Roman 12 e non in Calibri 10 come è scritto tutto il resto del messaggio. Si può cambiare? Ho provato anche a inserirlo come campo arrTabella(i, 2) _ nel foglio di lavoro in una cella accanto ma continua con lo stesso font.

Grazie ancora

Alessandro