Attacher tous les fichiers d'un dossier dans un mail

Hello !

Je me permets de vous solliciter car j'ai un petit programme dans lequel j'envoie un mail avec une pièce jointe.

La ligne correspondante est :

Cdo_msg.AddAttachment (chemin complet du fichier)

Comment peut on remplacer cette ligne pour envoyer tous les fichiers du dossier ?

merci pour votre aide !

Razid

Bonjour Razid,

Il faut utiliser une boucle avec Do While ... Loop et Dir()

  Dim sPathFic As String
  sPathFic = Dir("D:\Dossier\Sous-dossier\*.*")
  Do While sPathFic <> ""
    'Debug.Print sPathFic
    Cdo_msg.AddAttachment sPathFic
    sPathFic = Dir
  Loop

A+

Hello !

Merci pour le code, j'ai essayé mais il me dit pour la ligne Cdo_msg...... que le "protocole spécifié est inconnu" :(

Bonjour Razid

peut être faut -il ajouter en premiere ligne

Set Cdo_msg = CreateObject("CDO.Message")

Bonsoir !

J'ai déjà cette ligne dans mon code. Je vous mets tout le code ci-dessous.

Le but du code est d'envoyer à chaque adresse mail citée un document spécifique du dossier. Cette partie fonctionne très bien. Je voulais ajouter une partie permettant d'envoyer tous les fichiers à une autre personne ("responsable"). C'est là que je bloque...

Sub ENVOI()

    Dim cdo_msg As CDO.Message
    Dim expediteur As Variant
    Dim mdp As Variant
    Dim signature As Variant

    With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Rapport"
    .Show
    If .SelectedItems.Count > 0 Then dossier = .SelectedItems(1) & "\"
    End With

    expediteur = InputBox("Entre votre adresse mail", "Informations Expéditeur")
    mdp = InputBox("Entrez votre mot de passe", "Informations Expéditeur")
    With Sheets("Liste")
        dl = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = 9 To dl
            Set cdo_msg = CreateObject("cdo.message")
            cdo_msg.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com"
            cdo_msg.Configuration.Fields(cdoSMTPConnectionTimeout) = 60
            cdo_msg.Configuration.Fields(cdoSendUsingMethod) = cdoSendUsingPort
            cdo_msg.Configuration.Fields(cdoSMTPServerPort) = 465
            cdo_msg.Configuration.Fields(cdoSMTPAuthenticate) = cdoBasic
            cdo_msg.Configuration.Fields(cdoSMTPUseSSL) = True
            cdo_msg.Configuration.Fields(cdoSendUserName) = expediteur
            cdo_msg.Configuration.Fields(cdoSendPassword) = mdp
            cdo_msg.Configuration.Fields.Update

            prenom = .Cells(i, 3)
            nom = .Cells(i, 2)
            responsable = .Cells(5, 3)
            mailresponsable = .Cells(6, 3)
            cdo_msg.From = expediteur
            cdo_msg.To = .Cells(i, 4)
            cdo_msg.Subject = "Rapport"
            cdo_msg.TextBody = "Merci"
            cdo_msg.AddAttachment (dossier & prenom & " " & nom & ".pdf")
            cdo_msg.Send

        Next i

        cdo_msg.From = expediteur
        cdo_msg.To = mailprof

        Dim sPathFic As String
        sPathFic = Dir("C:\Users\Test\*.*")
        Do While sPathFic <> ""
            Debug.Print sPathFic
            cdo_msg.AddAttachment sPathFic
            sPathFic = Dir
        Loop

        cdo_msg.Subject = "Rapport général "
        cdo_msg.TextBody = "Merci"
        cdo_msg.Send
        Set cdo_msg = Nothing

    End With

End Sub

Salut Razid,

Le code donné n'est pas mis au bon endroit et il faut le modifier par rapport à votre configuration

Sub ENVOI()
    Dim cdo_msg As CDO.Message
    Dim expediteur As Variant
    Dim mdp As Variant
    Dim signature As Variant
    Dim sPathFic As String

    With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Rapport"
    .Show
    If .SelectedItems.Count > 0 Then dossier = .SelectedItems(1) & "\"
    End With

    expediteur = InputBox("Entre votre adresse mail", "Informations Expéditeur")
    mdp = InputBox("Entrez votre mot de passe", "Informations Expéditeur")
    With Sheets("Liste")
        dl = .Cells(Rows.Count, 2).End(xlUp).Row
        For i = 9 To dl
            Set cdo_msg = CreateObject("cdo.message")
            cdo_msg.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com"
            cdo_msg.Configuration.Fields(cdoSMTPConnectionTimeout) = 60
            cdo_msg.Configuration.Fields(cdoSendUsingMethod) = cdoSendUsingPort
            cdo_msg.Configuration.Fields(cdoSMTPServerPort) = 465
            cdo_msg.Configuration.Fields(cdoSMTPAuthenticate) = cdoBasic
            cdo_msg.Configuration.Fields(cdoSMTPUseSSL) = True
            cdo_msg.Configuration.Fields(cdoSendUserName) = expediteur
            cdo_msg.Configuration.Fields(cdoSendPassword) = mdp
            cdo_msg.Configuration.Fields.Update

            prenom = .Cells(i, 3)
            nom = .Cells(i, 2)
            responsable = .Cells(5, 3)
            mailresponsable = .Cells(6, 3)
            cdo_msg.From = expediteur
            cdo_msg.To = .Cells(i, 4)
            cdo_msg.Subject = "Rapport"
            cdo_msg.TextBody = "Merci"
            ' Envoyer tous les fichiers du dossier
            sPathFic = Dir(dossier & prenom & " " & nom)
            Do While sPathFic <> ""
                cdo_msg.AddAttachment sPathFic & ".pdf"
                sPathFic = Dir
            Loop
            cdo_msg.Send
        Next i
        cdo_msg.From = expediteur
        cdo_msg.To = mailprof
        cdo_msg.Subject = "Rapport général "
        cdo_msg.TextBody = "Merci"
        cdo_msg.Send
        Set cdo_msg = Nothing
    End With
End Sub

@+

Merci beaucoup pour le temps que vous prenez pour m'aider ! J'ai essayé le code et j'ai le message "Argument ou appel de procédure incorrect" pour la ligne sPathFic = Dir
Etant un débutant en VBA je ne sais pas du tout à quoi cela correspond ! :\

Bonjour Razid

Vous êtes sur PC ou Mac quelle version d'office avez-vous ?

@+

Bonjour,

j'ai une version Excel 2010 mais suite à votre question je viens d'essayer la macro sur un pc avec Office 365 j'ai le même souci...

Je n'ai pas Mac je suis sur windows

Bonsoir,

j'ai l'impression que personne n'a de piste pour résoudre mon problème :(

Des solutions?

Merci !

Razid

Bonjour,

Vous auriez posé votre demande correctement

Je me permets de vous solliciter car j'ai un petit programme dans lequel j'envoie un mail avec une pièce jointe.

La ligne correspondante est :

Cdo_msg.AddAttachment (chemin complet du fichier)

Comment peut on remplacer cette ligne pour envoyer tous les fichiers du dossier ?

Vous avez eu la réponse, à vous de l'adapter, 1 procédure pour envoyer le fichier au salarié + 1 (celle indiqué) pour envoyer au boss

Bonjour,

Merci pour votre réponse. Comme vous m'avez posé des questions sur les versions que j'utilise je pensais qu'il y avait une piste derrière ! Je me suis trompé :)

Je vais adapter le code et voir pourquoi j'ai ce message d'erreur qui empêche le code de fonctionner.

Merci encore pour votre aide !

Razid

Re,

Attention !
Pour éviter le message d'erreur, vous utilisez bien le code modifié

' Envoyer tous les fichiers du dossier
            sPathFic = Dir(dossier & prenom & " " & nom)
            Do While sPathFic <> ""
                cdo_msg.AddAttachment sPathFic & ".pdf"
                sPathFic = Dir
            Loop

Il faut un 1er Dir()

A+