Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel envoi email à partir d'excel

envoi email à partir d'excel

2 réponses
Avatar
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
Signaler un problème avec ce contenu

2 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
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" a écrit dans le message de news:
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



Avatar
Daniel.C
Oups.
Corrige :
Dim PJ(2) as string
Daniel
"Daniel.C" a écrit dans le message de news:

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" a écrit dans le message de news:
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