Macro per inviare allegati a più destinatari con vba

Anonimo

Ciao

ho trovato giá sul sito una macro fantastica che funziona alla perfezione é la seguente:

Tuttavia, io la devo addattare alla mia esigenza e no riesco:

vorrei infatti che ad ogni destinatario fosse inviata, invece che un singolo documento, una cartella contenente pdf.

Ho provato a sostituire al file in nome della cartella ma ancorché compressa non mi funziona la macro.

mi hanno accennato a cicle di mail ma non so proprio come impostarli.

ringrazio antocipatamente chi potra aiutarmi.

e grazie a Norman che mi ha gia aiutata tantissimo.

ciao

=========>>

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

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

Set WB = ThisWorkbook

Set SH = WB.Sheets(sFoglio)

With SH

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

Set Rng = .Range("A2:F" & 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)

sbody = "<H3>Gentile utente,</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." & _

" Per confermare l'iscrizione è necessario effettuare" & _

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

" Per qualsiasi chiarimento o dubbio, contatta " & _

"la Segreteria allo 02/xxxxxxxx o scrivi a " & _

"*** L'indirizzo di posta elettronica viene rimosso per motivi di privacy ***" & _

" Cordiali saluti " & _

" Cognome nome " & _

"Segreteria di direzione" & _

" Nome Azienda " & _

"N°telefono " & _

"sito web " & _

"indirizzo mail "

.display

.To = sIndirizzo

.CC = ""

.BCC = ""

.Subject = sOggetto

.HTMLBody = sbody & " " & .HTMLBody

.Attachments.Add sPercorso _

& Application.PathSeparator _

& sAllegato

.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, _

Optional sPassword As String)

Dim bProtected As Boolean

With SH

If Rng Is Nothing Then

Set Rng = .Cells

End If

bProtected = .ProtectContents = True

If bProtected Then

Application.ScreenUpdating = False

.Unprotect Password:=sPassword

End If

End With

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

If bProtected Then

SH.Protect Password:=sPassword, _

UserInterfaceOnly:=True

End If

Application.ScreenUpdating = True

End Function

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

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

Ciao Tiziana,

Norman ok l ho incollato ma mi dice sub o function non definita e mi evidenzia lastRow nel

modulo.. sto perdendo le speranze 😰 help me please

Ho ricevuto la tua email e ho scaricato il tuo file.

L'unico problema con il tuo codice è che hai inserito una riga vuota tra ogni riga. Nota inoltre che tutte le virgolette che racchiudono i percorsi elencati nella colonna F devono essere eliminate!

Ho quindi incollato il mio codice da questo thread su Modulo2 e questo codice viene eseguito senza alcun problema.

Potresti scaricare questo file aggiornato Tiziana201980927.xls

===

Regards,

Norman

0 commenti

16 risposte aggiuntive

Anonimo

2019-09-24T10:35:15+00:00

Norman buongiorno

ho provato la macro ma non mi funziona

problema 1:

mi risponde

sub o function non definita..

problema 2:

in realtà conla macro in questione io non riesco ad allegare a ciascun indirizzo la propria cartella ma riesco ad allegare la cartella definita a tutti i destinatari...:( mi confermi?

io vorrei che ciascun destinatario ricevesse la propria cartella....(

il foglio xls è così impostato:

mi dice che non è possibile in modalità interruzione ma cosa significa?

Grazie ancora
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2019-09-23T16:30:11+00:00

Ciao TIZIANAC1,

Ciao Norman io non ti conosco ma gia ti voglio bene.

ti chiedo solo una cosa, perche adesso non posso provarla... nelle cartelle che devo allegare.

1 devono essere compresse?

No, non ha importanza l'eventuale compressione dei file.

2 all’interno possono esserci due o piú pdf. Da inviare rispettivamente ai vari destinatari. Non c’é problema se il numero di file pdf all’interno delle varie cartelle é diverso vero?

Per quanto riguarda il codice, ci possono essere qualunque numero di file. Nota, tuttavia, che nel modo in cui viene scritto il codice, ogn i file nella directory di interesse verrà inviato come allegato. Se desideri escludere determinati tipi di file, posso facilmente modificare il codice.

domani la provo e ti so dire.

Io non sono un programmatore

e uso mi serve saper utilizzare le macro per lavoro.

Buon lavoro e a domani.

===

Regards,

Norman
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2019-09-23T16:12:51+00:00

Ciao Norman io non ti conosco ma gia ti voglio bene.

Siccome al momento non posso provarla... nelle cartelle che devo allegare per ciascun destinatario ..ti volevo ancora chiedere:

1 le cartelle devono essere compresse?

2 all’interno possono esserci due o piú pdf. E’ un problema se il numero di file pdf all’interno delle varie cartelle é diverso?

3 i pdf all’interno delle singole cartelle devono avere un progressivo? O possono avere dei nomi diversi. La macro li sente comunque?

Io non sono un programmatore scusami se faccio domande stupide uso vba per lavoro e mi arrangio come posso.

Grazie infinite per la tua preparazione e disponibilita’.
La risposta è stata utile?

0 commenti Nessun commento
Anonimo

2019-09-23T15:52:20+00:00

Ciao TIZIANAC1,

ho trovato giá sul sito una macro fantastica che funziona alla perfezione é la seguente:

Tuttavia, io la devo addattare alla mia esigenza e no riesco:

vorrei infatti che ad ogni destinatario fosse inviata, invece che un singolo documento, una cartella contenente pdf.

Ho provato a sostituire al file in nome della cartella ma ancorché compressa non mi funziona la macro.

mi hanno accennato a cicle di mail ma non so proprio come impostarli.

ringrazio antocipatamente chi potra aiutarmi.

e grazie a Norman che mi ha gia aiutata tantissimo.

=========>>

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

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

Set WB = ThisWorkbook

Set SH = WB.Sheets(sFoglio)

With SH

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

Set Rng = .Range("A2:F" & 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)

sbody = "<H3>Gentile utente,</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." & _

" Per confermare l'iscrizione è necessario effettuare" & _

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

" Per qualsiasi chiarimento o dubbio, contatta " & _

"la Segreteria allo 02/xxxxxxxx o scrivi a " & _

"*** L'indirizzo di posta elettronica viene rimosso per motivi di privacy ***" & _

" Cordiali saluti " & _

" Cognome nome " & _

"Segreteria di direzione" & _

" Nome Azienda " & _

"N°telefono " & _

"sito web " & _

"indirizzo mail "

.display

.To = sIndirizzo

.CC = ""

.BCC = ""

.Subject = sOggetto

.HTMLBody = sbody & " " & .HTMLBody

.Attachments.Add sPercorso _

& Application.PathSeparator _

& sAllegato

.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, _

Optional sPassword As String)

Dim bProtected As Boolean

With SH

If Rng Is Nothing Then

Set Rng = .Cells

End If

bProtected = .ProtectContents = True

If bProtected Then

Application.ScreenUpdating = False

.Unprotect Password:=sPassword

End If

End With

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

If bProtected Then

SH.Protect Password:=sPassword, _

UserInterfaceOnly:=True

End If

Application.ScreenUpdating = True

End Function

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

Supponendo che tutti i file nella directory di interesse debbano essere inviati a ciascuna persona, prova 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

Dim sbody As String

Dim sFile As String

Dim LRow As Long, i As Long

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

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

Const sPath As String = "C:\Pippo" '<<=== Modifica

Set WB = ThisWorkbook

Set SH = WB.Sheets(sFoglio)

With SH

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

Set Rng = .Range("A2:F" & 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)

sbody = "<H3>Gentile utente,</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." & _

" Per confermare l'iscrizione è necessario effettuare" & _

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

" Per qualsiasi chiarimento o dubbio, contatta " & _

"la Segreteria allo 02/xxxxxxxx o scrivi a " & _

"******@outlook.com" & _

" Cordiali saluti " & _

" Cognome nome " & _

"Segreteria di direzione" & _

" Nome Azienda " & _

"N°telefono " & _

"sito web " & _

"indirizzo mail "

.display

.To = sIndirizzo

.CC = ""

.BCC = ""

.Subject = sOggetto

.HTMLBody = sbody & " " & .HTMLBody

sFile = Dir(sPath & "*.*")

Do While Len(sFile) > 0

.Attachments.Add sPath & sFile

sFile = Dir

Loop

.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, _

Optional sPassword As String)

Dim bProtected As Boolean

With SH

If Rng Is Nothing Then

Set Rng = .Cells

End If

bProtected = .ProtectContents = True

If bProtected Then

Application.ScreenUpdating = False

.Unprotect Password:=sPassword

End If

End With

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

If bProtected Then

SH.Protect Password:=sPassword, _

UserInterfaceOnly:=True

End If

Application.ScreenUpdating = True

End Function

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

===

Regards,

Norman
La risposta è stata utile?

0 commenti Nessun commento