Récupérer une piece jointe d'un expediteur precis
Bonjour,
Objectif : récupérer une pièce jointe d'un mail en provenance d'un expéditeur précis puis la sauvegarder et la renommer en ajoutant soit " - 1200.txt" soit " - 2000.txt"
En consultant divers forum j'ai pu arranger le code vba suivant. Cependant en faisant la batterie de tests il m'indique en erreur qu'il ne trouve pas l'expéditeur et encore la PJ de l'expéditeur. Je précise évidemment bien indiqué le nom de l'expéditeur et le nom précis de la pj
Sub SaveAttachmentFromSpecificSender()
Dim OutlookApp As Object
Dim OutlookNamespace As Object
Dim OutlookFolder As Object
Dim OutlookMail As Object
Dim OutlookAttachment As Object
Dim saveFolder As String
Dim senderEmailAddress As String
Dim attachmentName As String
Dim foundAttachment As Boolean
Dim i As Integer
' Adresse email de l'expéditeur dont vous souhaitez récupérer la pièce jointe
senderEmailAddress = "expediteur@example.com"
' Nom de la pièce jointe que vous recherchez
attachmentName = "NomDeLaPieceJointe.pdf"
' Chemin du dossier où vous souhaitez sauvegarder la pièce jointe
saveFolder = "C:\Users\Utilisateur\Documents\PiecesJointes\"
' Initialisation de l'application Outlook
On Error Resume Next ' Ignorer les erreurs si Outlook n'est pas ouvert
Set OutlookApp = CreateObject("Outlook.Application")
On Error GoTo 0 ' Rétablir la gestion des erreurs normale
If OutlookApp Is Nothing Then
MsgBox "Outlook n'est pas disponible sur cet ordinateur.", vbExclamation
Exit Sub
End If
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
' Spécifiez le dossier de la boîte de réception où se trouve l'email
' Par exemple, Inbox ou un sous-dossier comme Inbox\Mes Emails
Set OutlookFolder = OutlookNamespace.GetDefaultFolder(6).Folders("SousDossier") ' 6 correspond à la boîte de réception
foundAttachment = False
' Boucle à travers tous les emails du dossier spécifié
For i = OutlookFolder.Items.Count To 1 Step -1
Set OutlookMail = OutlookFolder.Items(i)
' Vérifie si l'email provient de l'expéditeur spécifié
If OutlookMail.SenderEmailAddress = senderEmailAddress Then
' Vérifie si l'email a des pièces jointes
If OutlookMail.Attachments.Count > 0 Then
' Boucle à travers chaque pièce jointe
For Each OutlookAttachment In OutlookMail.Attachments
' Vérifie si le nom de la pièce jointe correspond à celui recherché
If OutlookAttachment.FileName = attachmentName Then
' Sauvegarde la pièce jointe dans le dossier spécifié
OutlookAttachment.SaveAsFile saveFolder & OutlookAttachment.FileName
foundAttachment = True
Exit For ' Sort de la boucle For Each OutlookAttachment
End If
Next OutlookAttachment
End If
End If
' Sort de la boucle For i si la pièce jointe a été trouvée
If foundAttachment Then Exit For
Next i
' Vérifie si la pièce jointe a été trouvée
If foundAttachment Then
MsgBox "La pièce jointe '" & attachmentName & "' de l'expéditeur '" & senderEmailAddress & "' a été sauvegardée avec succès dans " & saveFolder, vbInformation
Else
MsgBox "Aucune pièce jointe avec le nom '" & attachmentName & "' de l'expéditeur '" & senderEmailAddress & "' n'a été trouvée dans les emails spécifiés.", vbExclamation
End If
' Libère les ressources
Set OutlookAttachment = Nothing
Set OutlookMail = Nothing
Set OutlookFolder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End SubJe ne comprends donc pas pourquoi cette erreur remonte.
Dans une deuxième phase lorsque mon problème sera résolu je souhaiterai qu'il me sauvegarde cette pj MAIS qu'il la renomme par ce que j'ai indiqué plus haut.
Je vous remercie pour l'attention que vous porterez à ma problématique
Bonjour guibs
J'ai testé la procédure en modifiant les valeurs des 3 variables "senderEmailAddress", "attachmentName" et "saveFolder" et elle fonctionne correctement (sauvegarde de la pièce jointe de l'émetteur indiqué dans le dossier mentionné).
Par contre, rien dans le code ne traite le renommage de la pièce jointe.
Cdlt,
Cylfo
Bonjour Cylfo,
Merci de ta réponse. Pourtant de mon côté, j'ai un message d'erreur qui m'indique qu'il ne trouve pas l'expéditeur du mail avec la pièce jointe précise. J'ai essayé de tourner de différentes manières mais toujours rien.
Pour la partie renommage oui en effet je demande de l'aide pour implémenter le renommage de la pièce jointe
Bonjour guibs, le fil, le forum,
Ton code fonctionne si les conditions sont remplies, comme le mentionne Cylfo.
1- Microsoft Outlook est déjà démarré
2- senderEmailAddress = "expediteur@example.com" < modifier pour le courriel de l'expéditeur
3- attachmentName = "NomDeLaPieceJointe.pdf" < nom du document attaché (attention à la casse, aux accents et à l'extension du document)
4- saveFolder = "C:\Users\Utilisateur\Documents\PiecesJointes\" < modifier "Utilisateur" pour ton mon d'utilisateur de Windows (attention aux accents et aux espaces). Via l' "Explorateur de fichiers" de Windows, se rendre dans le dossier en question et y coller manuellement un fichier quelconque afin de t'assurer que tu aies le droit d'écriture. Profites-en pour cliquer dans la barre d'adresse au haut de l'Explorateur de fichier, pour voir, et éventuellement copier, le nom complet du chemin.
5- Set OutlookFolder = OutlookNamespace.GetDefaultFolder(6).Folders("SousDossier") < GetDefaultFolder(6) représente la "Boîte de réception" et "SousDossier" représente un sous-dossier de la "Boîte de réception" et non un dossier en bas de la "Boîte de réception".
Teste avec un courriel dans la " Boîte de réception " (comme si le courriel venait d'arriver) en utilisant " OutlookNamespace.OutlookNamespace.GetDefaultFolder(6) "
Bizz
Bonjour Bizz,
Merci pour ton retour.
Pour te répondre, j'ai respecté toutes les conditions que tu cites déjà au préalable pour les paramètres. Je me suis envoyé un mail à moi même aussi sans résultat dans ma boîte de réception. J'ai vérifié aussi qu'il soit en non lu. J'ai même changé l'expéditeur d'un mail que j'avais reçu en faisant attention qu'il y avait une PJ dans son mail et du coup changé le nom de la PJ.
Rien n'y fait j'ai toujours ce message comme quoi il ne trouve pas l'expéditeur du mail avec sa pièce jointe.
Le seul code qui fonctionne bien c'est si je ne précise pas un expéditeur en particulier et pas de PJ jointe précise et que je dis au code de me trouver dans ma boîte de réception de récupérer l'ensemble des pièces jointes. Mais ce n'est pas l'objectif souhaité puisqu'après je veux travailler en particulier sur une pièce jointe précise provenant d'un certain expéditeur.
J'avoue ne pas comprendre cette subtilité pour le moment
Bonjour guibs, le fil, le forum,
Insère : "MsgBox OutlookFolder" afin de vérifier si le nom représenté par "OutlookFolder" est bien celui prévu.
Le "MessageBox" devrait donner : "Boîte de réception" s'il n'y a pas de sous-dossier mentionné dans le chemin de recherche.
Pour situer l'ajout :
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
' Spécifiez le dossier de la boîte de réception où se trouve l'email
' Par exemple, Inbox ou un sous-dossier comme Inbox\Mes Emails
Set OutlookFolder = OutlookNamespace.GetDefaultFolder(6) ' 6 correspond à la boîte de réception
MsgBox OutlookFolder ' << ici
foundAttachment = False
Bizz
Bonjour la commu, salut Bizz
Voici mon retour. Toujours pareil de mon côté j'a une boite de dialogue qui s'affiche en effet mais toujours un message d'erreur et donc il ne teouve pas mon expediteur et encore moins la pj.
Bonjour guibs,
Pourrais tu joindre le fichier à ton post en anonymisant les données ?
Si tu ne l'as pas déjà fait, mets un point d'arrêt sur la 1ère instruction de la procedure et lorsque l'exécution s'interrompt sur cette ligne, déroules le code en mode pas à pas : est ce que tu passes dans les lignes de parcours des mails ?
Cdlt,
Cylfo
Bjr cylfo,
En fait le fichier ne contient absolument rien hormis un bouton auquel j'affecte la macro avec le code déjà fourni et pour lequel j'ai rajouté mes données + l'information de Bizz
Et tu as déroulé le code en mode "pas à pas" ?
Oui tout a fait
J'explore une autre approche de code mais tjrs le même souci. Il ne trouve absolument pas l'expediteur. Je lis sur les forum un éventuel problème au niveau du smtp
Bonjour guibs, le fil, le forum,
Est-ce possible que le Outlook concerné, soit un Outlook d'entreprises où tout roule sur serveur ?
Bizz
Bonjour guibs, le fil, le forum,
Un fichier test pour comprendre.
Assure-toi qu’Outlook est ouvert.
Clique sur le bouton. Un MessageBox va donner la liste des noms et des numéros des dossiers détectables.
Ce qui pourrait te donner le numéro du dossier sur lequel tu désires effectuer des opérations.
Si tu le trouves et qu'il est un autre numéro que le 6, pour tester ton autre fichier, modifie le 6 pour le numéro trouvé.
Set OutlookFolder = OutlookNamespace.GetDefaultFolder(6) ' < c'est ce 6 ci dont je parle.
Bizz
Bonjour à tous,
J'ai utilisée ton fichier avec les macro j'ai bien la boite de dialogue qui s'affiche. Je suis déjà configuré sur le 6 donc rien a changer si je ne m'abuse.
Résultat : toujours rien.
Je te confirme être sur un outlook d'entreprise étatique mais étant donné que j'ai pu récupéré les pj une fois à la condition de ne pas préciser de pj précise et de ne pas préciser l'adresse de l'expéditeur. Je ne vois pas ce qui pourrait faire la différence. A moins de changer d’approche sur le code vba mais là je sèche totalement.
Bonsoir,
Un truc bête ... ajoutes l'option "Option Compare Text" en tête du module, cela change quelque chose ?
Sinon, modifies ton code pour ne préciser ni l'expéditeur, ni pièce jointe particulière et insères dans la boucle de lecture des mails, une MsgBox qui, pour chaque mail contenant une pièce jointe, liste l'expéditeur et le nom de la pièce jointe. Parmi les msgbox, il y en a une qui liste l'expéditeur et la pièce jointe que tu veux sauvegarder ?
Cdlt,
Cylfo
Cylfo,
Non cela ne change rien malheureusement.
Quel serait le code du coup là tu m'as perdu.
Non parmi les msgbox il n'y en pas qui liste l'expéditeur ni la pièce jointe
Salut les amis,
Après moultes recherches et cette histoire de compte exchange car en effet les adresses mail sont gérées à partir de compte exchange et cela change tout effectivement. J'ai donc pu trouver un code vba qui fonctionne. En voici l'exemple. J'y ai implémenté un renommage comme je souhaitais au départ et qui plus est un renommage en fonction de la tranche d'heure d'arrivée du mail
Function GetSenderSMTPAddress(olItem As Object) As String
Dim olPA As Object
Dim olSender As Object
Dim senderSMTP As String
On Error Resume Next
Set olPA = olItem.PropertyAccessor
If Not olPA Is Nothing Then
senderSMTP = olPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001F")
If senderSMTP = "" Then
Set olSender = olItem.Sender
If Not olSender Is Nothing Then
senderSMTP = olSender.SmtpAddress
End If
End If
End If
GetSenderSMTPAddress = senderSMTP
End Function
Sub EnregistrerDernierePieceJointeServeurExchange()
Dim olApp As Object
Dim olNamespace As Object
Dim olFolder As Object
Dim olItems As Object
Dim olItem As Object
Dim olAttachment As Object
Dim saveFolder As String
Dim savePath As String
Dim senderEmail As String
Dim attachmentName As String
Dim foundEmail As Object
Dim senderSMTP As String
Dim newFileName As String ' Nouveau nom de fichier
Dim receivedHour As Integer ' Heure de réception de l'e-mail
' Chemin du dossier où enregistrer la pièce jointe
saveFolder = "C:\Users\gxxxxxxxxxxx.bxxxxxxxxx\Desktop\PJ\"
' Adresse e-mail de l'expéditeur à rechercher (serveur Exchange)
senderEmail = "gxxxxxxxxxxxxxx.bxxxxxxxxxx@xxxxxxxxxxxx.xxxxxxxxx.fr" ' Modifier selon l'adresse e-mail de l'expéditeur
' Nom de la pièce jointe à rechercher
attachmentName = "6DD.TXT" ' Modifier selon le nom de la pièce jointe recherchée
' Initialisation de l'application Outlook
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
If olApp Is Nothing Then
MsgBox "Outlook n'est pas installé sur cet ordinateur."
Exit Sub
End If
End If
' Récupération de l'espace de noms Outlook
Set olNamespace = olApp.GetNamespace("MAPI")
Const olFolderInbox As Integer = 6
' Récupération du dossier Boîte de réception
Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox)
' Vérification du succès de la récupération du dossier Boîte de réception
If olFolder Is Nothing Then
MsgBox "Impossible d'obtenir le dossier Boîte de réception."
Set olNamespace = Nothing
Set olApp = Nothing
Exit Sub
End If
' Récupération des e-mails triés par date d'arrivée décroissante
Set olItems = olFolder.Items
olItems.Sort "[ReceivedTime]", True
' Parcours des e-mails
For Each olItem In olItems
' Vérification si l'élément est un e-mail et provient de l'expéditeur spécifié
If TypeOf olItem Is Object And olItem.Class = 43 Then ' 43 correspond à olMail (MailItem en early binding)
' Obtenir l'adresse SMTP de l'expéditeur
senderSMTP = GetSenderSMTPAddress(olItem)
' Vérifier si l'e-mail provient de l'expéditeur spécifié
If senderSMTP = senderEmail Then
' Obtenir l'heure de réception de l'e-mail
receivedHour = Hour(olItem.ReceivedTime)
' Parcours des pièces jointes de l'e-mail
For Each olAttachment In olItem.Attachments
' Vérifier si la pièce jointe a le nom recherché
If olAttachment.Filename = attachmentName Then
' Construire le chemin complet pour enregistrer la pièce jointe
savePath = saveFolder & olAttachment.Filename
' Enregistrer la pièce jointe
olAttachment.SaveAsFile savePath
' Déterminer le nouveau nom en fonction de l'heure de réception
If (receivedHour >= 11 And receivedHour < 13) Or (receivedHour = 13 And Minute(olItem.ReceivedTime) < 45) Then
newFileName = "NomFichierEntre11h30Et13h45.txt"
ElseIf (receivedHour >= 18 And receivedHour < 20) Or (receivedHour = 20 And Minute(olItem.ReceivedTime) = 0) Then
newFileName = "NomFichierEntre18hEt20h.txt"
Else
newFileName = "AutreNomFichier.txt" ' Définir un nom par défaut si nécessaire
End If
' Renommer le fichier après l'avoir enregistré
Name savePath As saveFolder & newFileName
' Marquer l'e-mail comme lu si nécessaire
olItem.UnRead = False
' Conserver une référence à l'e-mail pour la gestion ultérieure si nécessaire
Set foundEmail = olItem
' Quitter la boucle après avoir trouvé la pièce jointe recherchée
Exit For
End If
Next olAttachment
End If
End If
' Quitter la boucle après avoir trouvé le dernier e-mail de l'expéditeur spécifié
If Not foundEmail Is Nothing Then Exit For
Next olItem
' Libérer les objets
Set olAttachment = Nothing
Set olItem = Nothing
Set olItems = Nothing
Set olFolder = Nothing
Set olNamespace = Nothing
Set olApp = Nothing
' Message de confirmation
If Not foundEmail Is Nothing Then
MsgBox "Dernière pièce jointe '" & attachmentName & "' de l'expéditeur '" & senderEmail & "' trouvée et enregistrée dans : " & saveFolder & newFileName
Else
MsgBox "Aucun e-mail trouvé avec la pièce jointe '" & attachmentName & "' de l'expéditeur '" & senderEmail & "'."
End If
End SubJe vous remercie pour votre aide
Bonjour,
Dans le code tu ne testes pas si le mail a déjà été lu, si ce test est suffisant il suffit de l'ajouter au début de la boucle ou après avoir vérifié l'émetteur.
' Parcours des e-mails
For Each olItem In olItems
' Vérification si l'élément est un e-mail et provient de l'expéditeur spécifié
If TypeOf olItem Is Object And olItem.Class = 43 Then ' 43 correspond à olMail (MailItem en early binding)
' Obtenir l'adresse SMTP de l'expéditeur
senderSMTP = GetSenderSMTPAddress(olItem)
' Vérifier si l'e-mail provient de l'expéditeur spécifié
If senderSMTP = senderEmail Then
If olItem.UnRead = True then
...Si c'est uniquement un problème de date, tu testes l'heure mais pas la date. Proposition de modification,
' Récupération des e-mails triés par date d'arrivée décroissante
Set olItems = olFolder.Items
olItems.Sort "[ReceivedTime]", True
Dim dCejour11h30 As Date
Dim dCejour13h45 As Date
Dim dCejour18h00 As Date
Dim dCejour20h00 As Date
dCejour11h30 = Date + (1 / 1440 * ((11 * 60) + 30))
dCejour13h45 = Date + (1 / 1440 * ((13 * 60) + 45))
dCejour18h00 = Date + (1 / 1440 * (18 * 60))
dCejour20h00 = Date + (1 / 1440 * (20 * 60))
' Parcours des e-mails
For Each olItem In olItems
' Vérification si l'élément est un e-mail et provient de l'expéditeur spécifié
If TypeOf olItem Is Object And olItem.Class = 43 Then ' 43 correspond à olMail (MailItem en early binding)
' Obtenir l'adresse SMTP de l'expéditeur
senderSMTP = GetSenderSMTPAddress(olItem)
' Vérifier si l'e-mail provient de l'expéditeur spécifié
If senderSMTP = senderEmail Then
' Parcours des pièces jointes de l'e-mail
For Each olAttachment In olItem.Attachments
' Vérifier si la pièce jointe a le nom recherché
If olAttachment.Filename = attachmentName Then
' Construire le chemin complet pour enregistrer la pièce jointe
savePath = saveFolder & olAttachment.Filename
' Enregistrer la pièce jointe
olAttachment.SaveAsFile savePath
' Déterminer le nouveau nom en fonction de l'heure de réception
If (olItem.ReceivedTime >= dCejour11h30 And olItem.ReceivedTime <= dCejour13h45) Then
newFileName = "NomFichierEntre11h30Et13h45.txt"
ElseIf (olItem.ReceivedTime >= dCejour18h00 And olItem.ReceivedTime <= dCejour20h00) Then
newFileName = "NomFichierEntre18hEt20h.txt"
Else
newFileName = "AutreNomFichier.txt" ' Définir un nom par défaut si nécessaire
End IfCdlt,
Cylfo
Bjr Cylfo,
Je vais tester cela et reviens vers toi plus tard j'ai commencé aussi à regarder et sur certains sites ça parle d'une approche qui comporterait moins de changement ou moins d'ajout. Je teste tout cela
Bonjour la Commu, Cylfo
Après les premiers essais, cela ne fonctionne pas. Il me récupère toujours la pa dernière pj de la veille donc j'avoue que je ne comprends pas car ta méthode semble apporter la solution.