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
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
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
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" <belmas.annemarie@free.fr> a écrit dans le message de news:
uZ%230aN9RIHA.5400@TK2MSFTNGP04.phx.gbl...
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
' 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
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
Oups.
Corrige :
Dim PJ(2) as string
Daniel
"Daniel.C" <dZZZcolardelle@free.fr> a écrit dans le message de news:
OcE9Py9RIHA.536@TK2MSFTNGP06.phx.gbl...
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" <belmas.annemarie@free.fr> a écrit dans le message de news:
uZ%230aN9RIHA.5400@TK2MSFTNGP04.phx.gbl...
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
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