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,

funziona alla grande!! Mi rimangono solo tre cose:

1. Devo scrivere prima dei dati

Spett.le, ho provato così ma mi da errore:

For i = 1 To UBound(arrTabella, 1)

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

        sHeader = "Spett.le"

                vbNewLine _

                arrTabella(i, 4) _

                & vbNewLine _

                & arrTabella(i, 6) _

                & vbNewLine _

                & arrTabella(i, 7) _

                & arrTabella(i, 8) _

                & vbNewLine & vbNewLine _

                & sGreeting _

                & arrTabella(i, 5)

2. Devo inserire il campo K2 prima del testo, sopra 

Sarebbe Caro Alessandro, (e poi il testo come sotto)

sMsg = "Ti trasmetto il questionario per la rilevazione " _

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

             & vbNewLine _

             & "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) _

             & vbNewLine & vbNewLine _

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

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

             & vbNewLine & vbNewLine _

             & "Allegato: " & sFile

3. devo allegare il file con nome uguale al campo C2 (& sFile) che trova al percorso:

Z:\Protocollo 2015\Centro \Nota \Lettere\ 

Ovviamente diverso per ogni record.

Grazie ancora 

Alessandro

Answer 3

Ciao Alessandro,

Prova a sostituire il tuo codice con la seguente 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 LRow As Long, i As Long, j As Long

    Const sSoggetto As String = "Cartelle in scadenza"

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

    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

            .EnableEvents = False

            .ScreenUpdating = False

        End With

    Set OutApp = CreateObject("Outlook.Application")

    For i = 1 To UBound(arrTabella, 1)

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

        sHeader = arrTabella(i, 4) _

                & vbNewLine _

                & arrTabella(i, 6) _

                & vbNewLine _

                & arrTabella(i, 7) _

                & vbNewLine _

                & arrTabella(i, 8) _

                & vbNewLine & vbNewLine _

                & sGreeting _

                & arrTabella(i, 5)

        sMsg = "Ti trasmetto il questionario per la rilevazione " _

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

             & vbNewLine _

             & "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) _

             & vbNewLine & vbNewLine _

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

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

             & vbNewLine & vbNewLine _

             & "Allegato: " & sFile             

        Set OutMail = OutApp.CreateItem(0)

        On Error Resume Next

        With OutMail

            .To = arrTabella(i, 9)

            .CC = arrTabella(i, 10)

            .BCC = ""

            .Subject = sSoggetto

            .body = sHeader & vbNewLine & vbNewLine & sMsg

            .Attachments.Add WB.Path & Application.PathSeparator & sFile

            .Send

            On Error GoTo 0

        End With

        Set OutMail = Nothing

    Next i

    On Error GoTo 0

    With Application

        .EnableEvents = True

        .ScreenUpdating = True

    End With

    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

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

Ho caricato il mio file di prova Alessandro20150622.xlsm a: http://1drv.ms/1FwBTde

===

Regards,

Norman

Answer 4

Ciao Norman,

ora è più chiaro? 

Grazie infinite per la disponibilità

Alessandro

Answer 5

Ciao Norman,

ecco il link dropbox

https://www.dropbox.com/s/gjnyyzslr2yvhs4/Campione%20Prova.xlsm?dl=0

Gli indirizzi mail sono in I2 e in copia (uno è presente l'altro no) in J2.

Ho modificato la posizione dei campi da inserire, quindi la mail da personalizzare diventerebbe:

Spett.le

(contenuto campo D2)

(contenuto campo F2)

(contenuto campo G2) (contenuto campo H2)

c.a. (contenuto E2)

(contenuto K2),

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 L2)

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

Alessandro

Allegato file (contenuto C2) 

Allegare il file in base al campo C2 che si trovano in una cartella.