VBA envoi mails avec pj dans différents dossiers

Question

Je reviens vers vous concernant une macro pour envoyer des mails avec pièces jointes via Outlook. Elle fonctionne très bien ! Néanmoins, je souhaiterais permettre qu'elle récupère des pièces jointes dans d'autres dossiers placés ailleurs (sur le serveur du boulot en l'occurence). En effet, souvent nos fichiers sont classés dans des dossiers différents. Cela permettrait d'éviter d'avoir à tout copié dans une dossier unique. Ce qui pourrait être bien c'est que la macro aille chercher le chemin dans une cellule du tableur dans laquelle elle serait renseignée. Par exemple la pièce jointe 1 pourrait être dans le dossier "\fileruser2\Users\XXX\Bureau\Macromails" (pour faire simple) ce chemin serait indiqué en cellule I2. Même fonctionnement pour d'autres pièces jointes se situant ailleurs. Quelqu'un pourrait m'aider à traduire ça en VBA ? Mon code actuel est dispo dans le fichier ci dessous. Merci pour votre lecture et pour votre aide...

Sequoyah · Accepted Answer

Bonjour x--ben,

vois si ça te convient, à adapter dans le code le chemin:

Sub Envoi_Mail()
    Dim Fichier1 As String 'il faut déclarer autant de variables que de fichiers à joindre
    Dim Fichier2 As String 'il faut déclarer autant de variables que de fichiers à joindre
    Dim Fichier3 As String 'il faut déclarer autant de variables que de fichiers à joindre
    Dim Chemin1 As String
    Dim Chemin2 As String
    Dim Chemin3 As String
    Dim Table(), j As Integer
    Dim fields As Variant
    Dim ws As Worksheet
    On Error Resume Next

    Set oOutlook = CreateObject("Outlook.Application")

    Chemin1 = "C:\Users\Sequoyah\Desktop\Forum\"  '====>> à adapter
    Chemin2 = "C:\Users\Sequoyah\Desktop\Forum\"  '====>> à adapter
    Chemin3 = "C:\Users\Sequoyah\Desktop\Forum\"  '====>> à adapter

    Set ws = ThisWorkbook.Sheets("Feuil1")   'Onglet ou feuille source de données ici Feuil1
    Table = ws.Range("A2:J6")   'Plage de données que l'on veut sur la feuille source de données

    For j = LBound(Table, 1) To UBound(Table, 1) 'on boucle chaque cellule de la première colonne de notre table
        Application.StatusBar = "Nom processing file # " & j & "/" & UBound(Table, 1)

        Fichier1 = Chemin1 & Table(j, 8) & ".docx" 'va chercher le nom de la PJ dans la colonne X du tableau et ajoute l'extention de fichier
'.docx. Si la PJ1 n'a pas toujours la même extension, il faut mettre changer l'extention
        Fichier2 = Chemin2 & Table(j, 9) & ".pdf"  'idem
        Fichier3 = Chemin3 & Table(j, 10) & ".txt"  'idem

        Set oMailItem = oOutlook.CreateItem(0)

'Set All Email Properties

        With oMailItem
            .Subject = Table(j, 3) & " " & Table(j, 2) & " - Dispositif apiculture" 'l'objet prend la valeur dans la colonne X et la complète avec le texte
            .To = Table(j, 7)
            .HTMLBody = "<font size=3><font face=Verdana> " & Table(j, 1) & " " & Table(j, 2) & ", <br>" _
            & "<br>" _
            & "Le dossier que vous avez déposé dans le cadre du dispositif d'aide exceptionnelle aux apiculteurs mis en place pour " & Table(j, 4) & " colonies a été accepté." _
            & " Ainsi, un aide d'un montant de " & Table(j, 6) & " € vous a été attribuée." _
            & " <br>" _
            & " Veuillez trouvez ci-joint les documents à fournir pour procéder au paiement de la subvention." _
            & "<br>" _
            & "<br>" _
            & "Cordialement </font>" _
            & "<br>" _
            & "<br>" _
' & Signature("NA")
            .Attachments.Add Fichier1
            .Attachments.Add Fichier2
            .Attachments.Add Fichier3
            .Display

'.Save      '<- sauvegarde l'email avant l'envoi (pour ne pas le sauvegarder, mettez cette ligne en commentaire)
'.Send      '<- envoie l'email (si vous voulez seulement préparer l'email et l'envoyer manuellement, mettez cette ligne en commentaire)
        End With

        Next j

'nettoyage...
        If (Not (oMailItem Is Nothing)) Then Set oMailItem = Nothing
        If (Not (oOutlook Is Nothing)) Then Set oOutlook = Nothing
    End Sub

    Function Signature(NouvelleAquitaine As String) As String
        Dim FSO As Object, TextStream As Object
        Dim nom_fichier As String

        Signature = Empty
        On Error Resume Next
        Set FSO = CreateObject("Scripting.FileSystemObject")
        nom_fichier = Environ("APPDATA") & "\Microsoft\Signatures\" & NA & ".htm" 'mettre nom de la signature
        Set TextStream = FSO.OpenTextFile(nom_fichier)
        If Err.Num = 0 Then
            Signature = TextStream.ReadAll
'remplacement adresse relative images par adresse absolue
            Signature = Replace(Signature, NA & "_fichiers/", Environ("APPDATA") & "\Microsoft\Signatures\" & NA & "_fichiers/")
        End If
    End Function

39macroenvoimailsseq.xlsm (19.10 Ko)

Sequoyah · Answer

Je viens de tester la macro sur plusieurs dossiers sur un serveur et ça marche sans problème. Tu es sûr d’avoir indiqué le chemin correctement? Par exemple Chemin3 = " \ fileruser2\Users\XXX\Bureau\Macromails \ " Pour éviter d’entrer le chemin dans le code on peut indiquer le chemin complet et le nom du fichier dans la cellule désirée...

Sequoyah · Answer

Bonjour x--ben, merci pour ton retour. Pour obtenir ce que tu demandes il doit y avoir un identifiant unique entre le destinataire de l’e-mail et le nom du sous dossier...