envoi email à partir d'excel

Le
nanie13
Bonjour,
Je suis débutante en vba, je voudrais la finaliser, quelqu'un pourrait t il
m'aider s'il vous plait.
Cette macro fonctionne, les émails sont envoyés "un par un" avec la pièce
jointe.
Comment joindre a 2° PJ et 3° PJ en conservant cette macro qui fonctionne.

Détail de ma feuille excel
Objet du message "Colonne U, ligne 5"
Message "Colonne U, ligne 11 à 26"
1° PJ "colonne U, ligne 7"
2° PJ "colonne U, ligne 8"
3° PJ "colonne U, ligne 9"

Sub Email()

' Filtre la colonne des adresses mails
Columns("O:O").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="<>"

' Déclaration des variables
Dim outlookDossier As Outlook.MAPIFolder
Dim outlookMessage As Outlook.MailItem
Dim vAdresse As String
Dim vObjet As String
Dim vMessage As String
Dim PJ As String
Dim vCellule As Object

' Récupération du message
For Each vCellule In Range("U11:U26")
vMessage = vMessage & vCellule & Chr(10)
Next

' Ajout pièce jointe
If PJ <> "" Then
If Dir(PJ, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbArchive)
= "" Then
MsgBox "fichier introuvable !", vbCritical, "Attention"
Set outlookDossier = Nothing
Set outlookMessage = Nothing
Exit Sub
End If
End If

' Envoi les messages à tout le groupe
Range("O2").Select
Do While ActiveCell <> ""
vAdresse = ActiveCell
vObjet = Range("U5")
PJ = Range("U7")
Set outlookDossier = GetObject("",
"Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set outlookMessage = outlookDossier.Items.Add
With outlookMessage
.Subject = vObjet
.Recipients.Add vAdresse
.Body = vMessage
.OriginatorDeliveryReportRequested = True
.ReadReceiptRequested = True
.Attachments.Add PJ
.Send
End With
ActiveCell.Offset(0, 1) = "x"
ActiveCell.Offset(1, 0).Select
Loop
Set outlookMessage = Nothing
Set outlookDossier = Nothing

' Supprime le filtrage de la colonne des émails
Selection.AutoFilter
ActiveWorkbook.Save
End Sub
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Daniel.C
Le #5344191
Bonjour.
Essaie comme ça (non testé) :

Sub Email()

' Filtre la colonne des adresses mails
Columns("O:O").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="<>"

' Déclaration des variables
Dim outlookDossier As Outlook.MAPIFolder
Dim outlookMessage As Outlook.MailItem
Dim vAdresse As String
Dim vObjet As String
Dim vMessage As String
Dim PJ
Dim vCellule As Object

' Récupération du message
For Each vCellule In Range("U11:U26")
vMessage = vMessage & vCellule & Chr(10)
Next

' Ajout pièce jointe
for i=0 to 2
If [U7].offset(i) <> "" Then
If Dir([U7].offset(i), vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or
vbArchive)
= "" Then
MsgBox "fichier introuvable !", vbCritical, "Attention"
Set outlookDossier = Nothing
Set outlookMessage = Nothing
Exit Sub
End If
PJ(i)=[U7].offset(i)
End If

' Envoi les messages à tout le groupe
Range("O2").Select
Do While ActiveCell <> ""
vAdresse = ActiveCell
vObjet = Range("U5")
PJ = Range("U7")
Set outlookDossier = GetObject("",
"Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set outlookMessage = outlookDossier.Items.Add
With outlookMessage
.Subject = vObjet
.Recipients.Add vAdresse
.Body = vMessage
.OriginatorDeliveryReportRequested = True
.ReadReceiptRequested = True
.Attachments.Add PJ
.Send
End With
ActiveCell.Offset(0, 1) = "x"
ActiveCell.Offset(1, 0).Select
Loop
Set outlookMessage = Nothing
Set outlookDossier = Nothing

' Supprime le filtrage de la colonne des émails
Selection.AutoFilter
ActiveWorkbook.Save
End Sub

Cordialement.
Daniel

"nanie13" uZ%
Bonjour,
Je suis débutante en vba, je voudrais la finaliser, quelqu'un pourrait t
il m'aider s'il vous plait.
Cette macro fonctionne, les émails sont envoyés "un par un" avec la pièce
jointe.
Comment joindre a 2° PJ et 3° PJ en conservant cette macro qui fonctionne.

Détail de ma feuille excel
Objet du message "Colonne U, ligne 5"
Message "Colonne U, ligne 11 à 26"
1° PJ "colonne U, ligne 7"
2° PJ "colonne U, ligne 8"
3° PJ "colonne U, ligne 9"

Sub Email()

' Filtre la colonne des adresses mails
Columns("O:O").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="<>"

' Déclaration des variables
Dim outlookDossier As Outlook.MAPIFolder
Dim outlookMessage As Outlook.MailItem
Dim vAdresse As String
Dim vObjet As String
Dim vMessage As String
Dim PJ As String
Dim vCellule As Object

' Récupération du message
For Each vCellule In Range("U11:U26")
vMessage = vMessage & vCellule & Chr(10)
Next

' Ajout pièce jointe
If PJ <> "" Then
If Dir(PJ, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbArchive)
= "" Then
MsgBox "fichier introuvable !", vbCritical, "Attention"
Set outlookDossier = Nothing
Set outlookMessage = Nothing
Exit Sub
End If
End If

' Envoi les messages à tout le groupe
Range("O2").Select
Do While ActiveCell <> ""
vAdresse = ActiveCell
vObjet = Range("U5")
PJ = Range("U7")
Set outlookDossier = GetObject("",
"Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set outlookMessage = outlookDossier.Items.Add
With outlookMessage
.Subject = vObjet
.Recipients.Add vAdresse
.Body = vMessage
.OriginatorDeliveryReportRequested = True
.ReadReceiptRequested = True
.Attachments.Add PJ
.Send
End With
ActiveCell.Offset(0, 1) = "x"
ActiveCell.Offset(1, 0).Select
Loop
Set outlookMessage = Nothing
Set outlookDossier = Nothing

' Supprime le filtrage de la colonne des émails
Selection.AutoFilter
ActiveWorkbook.Save
End Sub



Daniel.C
Le #5343941
Oups.
Corrige :
Dim PJ(2) as string
Daniel
"Daniel.C"
Bonjour.
Essaie comme ça (non testé) :

Sub Email()

' Filtre la colonne des adresses mails
Columns("O:O").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="<>"

' Déclaration des variables
Dim outlookDossier As Outlook.MAPIFolder
Dim outlookMessage As Outlook.MailItem
Dim vAdresse As String
Dim vObjet As String
Dim vMessage As String
Dim PJ
Dim vCellule As Object

' Récupération du message
For Each vCellule In Range("U11:U26")
vMessage = vMessage & vCellule & Chr(10)
Next

' Ajout pièce jointe
for i=0 to 2
If [U7].offset(i) <> "" Then
If Dir([U7].offset(i), vbNormal Or vbReadOnly Or vbHidden Or vbSystem
Or vbArchive)
= "" Then
MsgBox "fichier introuvable !", vbCritical, "Attention"
Set outlookDossier = Nothing
Set outlookMessage = Nothing
Exit Sub
End If
PJ(i)=[U7].offset(i)
End If

' Envoi les messages à tout le groupe
Range("O2").Select
Do While ActiveCell <> ""
vAdresse = ActiveCell
vObjet = Range("U5")
PJ = Range("U7")
Set outlookDossier = GetObject("",
"Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set outlookMessage = outlookDossier.Items.Add
With outlookMessage
.Subject = vObjet
.Recipients.Add vAdresse
.Body = vMessage
.OriginatorDeliveryReportRequested = True
.ReadReceiptRequested = True
.Attachments.Add PJ
.Send
End With
ActiveCell.Offset(0, 1) = "x"
ActiveCell.Offset(1, 0).Select
Loop
Set outlookMessage = Nothing
Set outlookDossier = Nothing

' Supprime le filtrage de la colonne des émails
Selection.AutoFilter
ActiveWorkbook.Save
End Sub

Cordialement.
Daniel

"nanie13" uZ%
Bonjour,
Je suis débutante en vba, je voudrais la finaliser, quelqu'un pourrait t
il m'aider s'il vous plait.
Cette macro fonctionne, les émails sont envoyés "un par un" avec la pièce
jointe.
Comment joindre a 2° PJ et 3° PJ en conservant cette macro qui
fonctionne.

Détail de ma feuille excel
Objet du message "Colonne U, ligne 5"
Message "Colonne U, ligne 11 à 26"
1° PJ "colonne U, ligne 7"
2° PJ "colonne U, ligne 8"
3° PJ "colonne U, ligne 9"

Sub Email()

' Filtre la colonne des adresses mails
Columns("O:O").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="<>"

' Déclaration des variables
Dim outlookDossier As Outlook.MAPIFolder
Dim outlookMessage As Outlook.MailItem
Dim vAdresse As String
Dim vObjet As String
Dim vMessage As String
Dim PJ As String
Dim vCellule As Object

' Récupération du message
For Each vCellule In Range("U11:U26")
vMessage = vMessage & vCellule & Chr(10)
Next

' Ajout pièce jointe
If PJ <> "" Then
If Dir(PJ, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or
vbArchive) = "" Then
MsgBox "fichier introuvable !", vbCritical, "Attention"
Set outlookDossier = Nothing
Set outlookMessage = Nothing
Exit Sub
End If
End If

' Envoi les messages à tout le groupe
Range("O2").Select
Do While ActiveCell <> ""
vAdresse = ActiveCell
vObjet = Range("U5")
PJ = Range("U7")
Set outlookDossier = GetObject("",
"Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set outlookMessage = outlookDossier.Items.Add
With outlookMessage
.Subject = vObjet
.Recipients.Add vAdresse
.Body = vMessage
.OriginatorDeliveryReportRequested = True
.ReadReceiptRequested = True
.Attachments.Add PJ
.Send
End With
ActiveCell.Offset(0, 1) = "x"
ActiveCell.Offset(1, 0).Select
Loop
Set outlookMessage = Nothing
Set outlookDossier = Nothing

' Supprime le filtrage de la colonne des émails
Selection.AutoFilter
ActiveWorkbook.Save
End Sub







Publicité
Poster une réponse
Anonyme