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+