PJ outlook à partir d'excel

Question

Bonjour,
J'ai réalisé une macro à partir d'excel pour envoyer des mails.
Cette dernière fonctionne, mais j'aimerais la finaliser.
Pas moyen de trouver le code pour joindre des pièces jointes 

Le fichier à joindre est renseigné dans la cellule "U7" de ma feuille excel

Sub Email()


' 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 vCellule As Object


' Récupération du message
    For Each vCellule In Range("U9:U24")
        vMessage = vMessage & vCellule & Chr(10)
    Next
    
' Envoi les messages à tout le groupe
Range("O2").Select
Do While ActiveCell <> ""
    vAdresse = ActiveCell
    vObjet = Range("U5")
    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
        .Send
    End With

cs_MPi · Answer

Regarde du côté de  
.Attachments(1) 

et assure-toi que la cellule U7 contient bien tout le chemin du fichier à joindre.

MPi²

cs_nanie13 · Answer

Re
Je ne sais pas comment formuler ce code.
Pourriez vous me l'écrire s'il vous plait ?
Merci

cs_MPi · Answer

Voici un exemple:
    Dim OutlookApp As New Outlook.Application
    Dim NewMail As Outlook.MailItem
       
    Set NewMail =  OutlookApp.CreateItem(olMailItem)
    
    NewMail.To = "AdresseMail@serveur.com"
    NewMail.Subject = "Sujet du courrier"
    NewMail.Body = "Le corps du message"
    NewMail.Attachments.Add "C:\Test.txt"
    NewMail.Display  ' ou .Send

Si tu regardes dans ton aide sur le mot Attachments, tu devrais trouver facilement ceci:
[olmthCreateItem.htm  CreateItem ] pour créer un message 
électronique, attacher un classeur Microsoft Excel en tant que pièce jointe (et 
non un lien) à l'aide de la propriété [olproAttachments.htm Attachments], puis lui affecter une 
légende descriptive.

Set myOlApp  = CreateObject("Outlook.Application")
Set myItem =  myOlApp.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments
myAttachments. Add  "C:\My Documents\Q496.xls", _
    olByValue, 1, "4th Quarter 1996 Results Chart"

Cet exemple Visual Basic Édition Applications montre comment créer un 
message électronique et joindre, à l'aide d'un lien, un document Microsoft Word 
à partir d'un serveur.

Set myOlApp  = CreateObject("Outlook.Application")
Set myItem =  myOlApp.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments
Set myAttachment = myAttachments. Add  _
"\MYSVR1\Reports\Q496Report.doc", _
    olByReference

Cet exemple Visual Basic Édition Applications montre comment créer un 
message électronique et joindre le premier contact du dossier Contacts par 
défaut.

Set myOlApp  = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNameSpace("MAPI")
Set myFolder = _
    myNameSpace.GetDefaultFolder(olFolderContacts)
Set myFirstContact = myFolder.Items(1)
Set myItem = myOlApp.CreateItem(olMailItem)
Set myAttachments = myItem.Attachments
myAttachments.Add myFirstContact

Cet exemple montre comment effectuer la même action à l'aide de 
VBScript.

Set myNameSpace = Application.GetNameSpace("MAPI")
Set myFolder = _
    myNameSpace.GetDefaultFolder(10)
Set myFirstContact = myFolder.Items(1)
Set myItem = Application.CreateItem(0)
Set myAttachments = myItem.Attachments
myAttachments.Add myFirstContact


MPi²

cs_nanie13 · Answer

Bonjour, Pourriez vous m'aider à finaliser cette macro s'il vous plait Je souhaiterais mettre plusieurs pièces jointes. Merci 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("U9:U24") 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

cs_MPi · Answer

Premièrement, ceci ne fonctionnera jamais puisque PJ = "" par défaut
Tu ne lui donnes aucune valeur donc = ""

' 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

Ensuite, dans ton code tu affectes à PJ la cellule U7
Si tu as plusieurs fichiers fichiers à joindre, il faudrait savoir où ils sont inscrits ... sinon  faut-il joindre tous les fichiers d'un répertoire particulier ?

MPi²

cs_nanie13 · Answer

Bonjour,

La macro fonctionne parfaitement, la pièce jointe est envoyée avec le mail.

Cellule U7":
c:\Documents and Settings\Anne Marie\Mes Documents\Belmas Eric\fichier.pdf

Que dois je écrire pour joindre plusieurs fichiers ?

Faut il que ces fichiers soient dans un même dossier ?

Je suis débutante et j'ai besoin d'aide car je n'arrive pas à concrétiser mon projet.

Merci de votre aide

cs_MPi · Answer

Comme je disais, la pièce jointe est déclarée en U7. Si tu veux joindre plusieurs fichiers, il faudrait que tu utilises autant de cellules que nécessaire pour inscrire les noms de ces fichiers... Et là, je conserve ton idée de base d'inscrire les fichiers et leurs chemins dans des cellules.

Les fichiers n'ont pas besoin d'être dans le même répertoire. L'important, c'est que tout le chemin et le nom soient inscrits dans une cellule.

Disons que tu as 3 fichiers inscrits dans U7, U8 et U9
Tu n'as qu'à faire une boucle et ajouter les fichiers un à un.
Quelque chose comme
For i = 7 to 9
    outlookMessage.Attachments.Add Range("U" & i)
Next

MPi²

cs_nanie13 · Answer

Bonjour,

Les 3 fichiers sont dans U7, U8 et U9.

Je ne sais pas ou écrire ce code, ni ou le positionner dans la macro :

For i = 7 to 9
    outlookMessage.Attachments.Add Range("U" & i)
Next

Faut t il déclarer : Dim i ?

Je suis débutante et je patauge.

Merci

cs_MPi · Answer

Je n'ai pas testé ce qui suit mais ça devrait fonctionner
Il y a tout de même quelque chose que je saisis mal... Est-ce que tu veux envoyer un même mail à plusieurs personnes contenant plusieurs fichiers ? Ou est-ce que tu envoies un mail à chacune des personnes, séparément, et avec un fichier particulier à chacune... ?

    Dim OutlookApp As New Outlook.Application
    Dim NewMail As Outlook.MailItem
    Dim I as Integer
    
    'Initialisation de l'objet Message   
    Set NewMail = OutlookApp.CreateItem(olMailItem)
    
    'Le sujet est inscrit en U5
    NewMail.Subject = Range("U5")  

    'Le corps du message est inscrit dans la colonne U, lignes 9 à 24
    For I = 9 to 24
        NewMail.Body = NewMail.Body & Range("U" & i) & vbcrlf
    Next
     
    'Les adresses sont dans la colonne O, lignes 2 à 10
    For i = 2 to 10
        NewMail.To = NewMail.To & Range("O" & i) & ";"
    Next

    'Les fichiers à joindre sont inscrits dans la colonne U, Lignes 6 à 8
    For i = 6 to 8
        NewMail.Attachments.Add Range("U" & i)
    Next

    NewMail.OriginatorDeliveryReportRequested = True
    NewMail.ReadReceiptRequested = True

    NewMail.Display  ' ou .Send

Il ne te reste qu'à ajuster les cellules lues selon tes besoins

MPi²

cs_nanie13 · Answer

Bonjour, Que la magie de Noël vous apporte joie et gaieté, qu’elle soit le prélude d’une nouvelle année emplie de bonheur, de paix et de sérénité pour vous et ceux qui vous sont proche. La macro que j’ai réalisé fonctionne, les emails sont expédiés, un à un, a toutes les personnes possédant une adresse email, puisque la colonne a été filtrée. Mon problème vient du code pour insérer les pièces jointes : je souhaiterais envoyer plusieurs pièces jointes, les mêmes, à tous. Avec mon code je ne peux envoyer qu’une pièce jointe à tous. Elle fonctionne et les emails sont expédiés avec la pièce jointe, j’ai testé ma macro. Pourriez-vous m’aider à finaliser cette macro pour que je puisse insérer plusieurs PJ 1ère PJ : colonne U, ligne 7 2ème PJ : colonne U, ligne 8 3ème PJ : colonne U, ligne 9 Sub Email () ' Filtre la colonne des adresses mails car certaines sont vides 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 dans la colonne U, ligne 11 à 26 For Each vCellule In Range("U11:U26") vMessage = vMessage & vCellule & Chr(10) Next ' Ajout la de la pièce jointe renseigné plus bas, colonne U, ligne 7 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, un par un 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 ‘ Ajoute un x dans la cellule lorsque les emails sont expédiés 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

cs_MPi · Answer

Salut, as-tu essayé le bout de code que je t'ai mis ? Au risque de me répéter, ceci ne sert à rien puisque PJ n'a jamais reçu de valeur ' Ajout la de la pièce jointe renseigné plus bas, colonne U, ligne 7 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 ------------------------------------------------ Range("O2").Select Do While ActiveCell <> "" 'pourquoi mettre une boucle ici ??? vAdresse = ActiveCell vObjet = Range("U5") PJ = Range("U7") 'Ici l'objet outlookDossier est réinitialisé à chaque tour de boucle... Set outlookDossier = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) Set outlookMessage = outlookDossier.Items.Add With outlookMessage 'On est toujours dans la boucle... et ça ne fait pas de senas... .Subject = vObjet .Recipients.Add vAdresse .Body = vMessage .OriginatorDeliveryReportRequested = True .ReadReceiptRequested = True .Attachments.Add PJ .Send 'ici aussi on est toujours dans la boucle ... !!! End With ' Ajoute un x dans la cellule lorsque les emails sont expédiés ActiveCell.Offset(0, 1) = "x" ActiveCell.Offset(1, 0).Select Loop MPi²

PJ outlook à partir d'excel

11 réponses

Votre réponse

Discussions similaires