Récupérer une piece jointe d'un expediteur precis
C
Re,
Oui, c'est bizarre. Peux-tu communiquer le code complet de la procédure que tu as modifiée ?
Cdlt,
Cylfo
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
Dim ReceivedTime As Integer
'Dim currentDate As Date ' Date actuelle
' Chemin du dossier où enregistrer la pièce jointe
saveFolder = "G:\USB -xxx xxx - xxxx\MAJ CYCLE\" & Format(Date, "mm") & " - " & UCase(Format(Date, "mmmm")) & "\" & Format(Date, "ddmmyyyy") & "\"
' Adresse e-mail de l'expéditeur à rechercher (serveur Exchange)
senderEmail = "jvvvvvvv.vvvvvvvvvvv@vvvvvvvvvvvvvvvvv.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
Dim dCejour11h30 As Date
Dim dCejour11h45 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))
' Obtenir la date actuelle
'currentDate = Date
' 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
' 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 (olItem.ReceivedTime >= dCejour11h30 And olItem.ReceivedTime <= dCejour13h45) Then
newFileName = "6WW - 1430z.txt"
ElseIf (olItem.ReceivedTime >= dCejour18h00 And olItem.ReceivedTime <= dCejour20h00) Then
newFileName = "6WW - 2030z.txt"
Else
newFileName = "AutreNomFichier.txt" ' Définir un nom par défaut si nécessaire
End If
'If (receivedHour >= 11 And receivedHour < 13) Or (receivedHour = 13 And Minute(olItem.ReceivedTime) < 45) Then
' newFileName = "6DD - 1430z.txt"
' ElseIf (receivedHour >= 18 And receivedHour < 20) Or (receivedHour = 20 And Minute(olItem.ReceivedTime) = 0) Then
' newFileName = "6DD - 2030z.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
Else
MsgBox "Aucun e-mail trouvé avec la pièce jointe '" & attachmentName & "' de l'expéditeur '" & senderEmail & "'."
End If
End Subvoici le code j'ai surement mal recopier tes informations c'est fort possible :
C
Re,
Cela vient du "Else" dans les tests des dates car si le fichier n'est pas compris dans les dates souhaitées, le "Else" lui est traité et du coup le fichier est considéré comme trouvé. J'ai modifié 2, 3 petits trucs dont la déclaration de la variable "dCeJour11h45" par "dCejour13h45" .
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
Dim ReceivedTime As Integer
'Dim currentDate As Date ' Date actuelle
' Chemin du dossier où enregistrer la pièce jointe
saveFolder = "G:\USB -xxx xxx - xxxx\MAJ CYCLE\" & Format(Date, "mm") & " - " & UCase(Format(Date, "mmmm")) & "\" & Format(Date, "ddmmyyyy") & "\"
' Adresse e-mail de l'expéditeur à rechercher (serveur Exchange)
senderEmail = "jvvvvvvv.vvvvvvvvvvv@vvvvvvvvvvvvvvvvv.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
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))
' Obtenir la date actuelle
'currentDate = Date
' Parcours des e-mails
Set foundEmail = Nothing
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
' 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 (olItem.ReceivedTime >= dCejour11h30 And olItem.ReceivedTime <= dCejour13h45) Then
newFileName = "6WW - 1430z.txt"
ElseIf (olItem.ReceivedTime >= dCejour18h00 And olItem.ReceivedTime <= dCejour20h00) Then
newFileName = "6WW - 2030z.txt"
'Else
' newFileName = "AutreNomFichier.txt" ' Définir un nom par défaut si nécessaire
End If
'If (receivedHour >= 11 And receivedHour < 13) Or (receivedHour = 13 And Minute(olItem.ReceivedTime) < 45) Then
' newFileName = "6DD - 1430z.txt"
' ElseIf (receivedHour >= 18 And receivedHour < 20) Or (receivedHour = 20 And Minute(olItem.ReceivedTime) = 0) Then
' newFileName = "6DD - 2030z.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
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
Else
MsgBox "Aucun e-mail trouvé avec la pièce jointe '" & attachmentName & "' de l'expéditeur '" & senderEmail & "'."
End If
Set foundEmail = Nothing
End SubCdlt,
Cylfo
Cela fonctionne à merveille. Et dans le doute pour le code précédent j'ai réaffecté la macro et cela fonctionnait aussi désolé du coup c'est ma faute.
En revanche, la moulinette de recherche est assez longue y'a-t-il un moyen de diminuer le temps de recherche parce que du coup les 4 clics que je faisais avant c'était plus rapide finalement ?
Je rectifie c'est la moulinette de recherche qui est longue lorsqu'elle ne trouve pas de fichier et la moulinette lorsque le fichier existe déjà sur la clé USB peut-on optimiser cela ?
C
Re,
Pour la moulinette de recherche : Dans la mesure où tu tries les mails par date de réception décroissante, tu pourrais interrompre la recherche dès que la date du mail traité est antérieure à la date du jour (ou antérieure à la date que tu veux traiter).
Pour la sauvegarde : je ne comprends pas, dans le code il n'y a rien qui traite de la présence préalable d'un fichier. Avec "Name xx As yyy", tu as dans ce cas là uniquement une erreur d'exécution 58 qui t'indique que le fichier existe déjà. Je n'ai pas compris non plus l'histoire des 4 clics
Cdlt,
Cylfo
Bon je crois que je vais abandonner car même avec ce code ci dessous je n'obtiens pas le résultat escompté c'est-à-dire qu'il m'enregistre la pièce jointe sous le même nom que lorsqu'elle arrive dans le mail de l'expéditeur c'est-à-dire "6DD.TXT" ce qui fait que j'ai cette dernière plus "6WW - 1430z.txt"
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 ReceivedTime As Integer
' Chemin du dossier où enregistrer la pièce jointe sur la clé USB
saveFolder = "G:\USB -xxx xxx - xxxx\MAJ CYCLE\" & Format(Date, "mm") & " - " & UCase(Format(Date, "mmmm")) & "\" & Format(Date, "ddmmyyyy") & "\"
' Adresse e-mail de l'expéditeur à rechercher (serveur Exchange)
senderEmail = "jvvvvvvv.vvvvvvvvvvv@vvvvvvvvvvvvvvvvv.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
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
Set foundEmail = Nothing
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
' 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
' Vérifier si le fichier existe déjà sur la clé USB
If Not FileExistsOnUSB(savePath) Then
' Enregistrer la pièce jointe sur la clé USB
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 = "6WW - 1430z.txt"
ElseIf (olItem.ReceivedTime >= dCejour18h00 And olItem.ReceivedTime <= dCejour20h00) Then
newFileName = "6WW - 2030z.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
Else
' La pièce jointe existe déjà sur la clé USB, ne rien faire dans ce cas
MsgBox "La pièce jointe '" & attachmentName & "' existe déjà sur la clé USB."
End If
End If
Next olAttachment
End If
End If
End If
' Sortir de la boucle externe 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
' Afficher un message si aucune pièce jointe n'a été trouvée
If foundEmail Is Nothing Then
MsgBox "Aucun e-mail trouvé avec la pièce jointe '" & attachmentName & "' de l'expéditeur '" & senderEmail & "'."
End If
Set foundEmail = Nothing
End Sub
Function FileExistsOnUSB(filePath As String) As Boolean
' Vérifie si un fichier existe sur la clé USB à l'emplacement spécifié
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
FileExistsOnUSB = fso.FileExists(filePath)
Set fso = Nothing
End FunctionC
Avec la procédure modifiée ci-dessous, cela ne résout pas le problème ? (j'ai aussi ajouté la ligne d'optimisation sur le parcours des mails que tu peux retirer)
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 ReceivedTime As Integer
' Chemin du dossier où enregistrer la pièce jointe sur la clé USB
saveFolder = "G:\USB -xxx xxx - xxxx\MAJ CYCLE\" & Format(Date, "mm") & " - " & UCase(Format(Date, "mmmm")) & "\" & Format(Date, "ddmmyyyy") & "\"
' Adresse e-mail de l'expéditeur à rechercher (serveur Exchange)
senderEmail = "jvvvvvvv.vvvvvvvvvvv@vvvvvvvvvvvvvvvvv.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
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
Set foundEmail = Nothing
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)
' Arrêter de parcourir les mails si la date de réception est strictement inférieure à la date du jour
If Int(olItem.ReceivedTime) < Date Then Exit For
' 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
' 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
' Déterminer le nouveau nom en fonction de l'heure de réception
If (olItem.ReceivedTime >= dCejour11h30 And olItem.ReceivedTime <= dCejour13h45) Then
newFileName = "6WW - 1430z.txt"
ElseIf (olItem.ReceivedTime >= dCejour18h00 And olItem.ReceivedTime <= dCejour20h00) Then
newFileName = "6WW - 2030z.txt"
Else
' au cas où la pièce serait réceptionnée en dehors des heures prévues
newFileName = "6WW - hhmmz.txt"
End If
' Construire le chemin complet pour enregistrer la pièce jointe
savePath = saveFolder & newFileName
' Vérifier si le fichier existe déjà sur la clé USB
If Not FileExistsOnUSB(savePath) Then
' Enregistrer la pièce jointe sur la clé USB
olAttachment.SaveAsFile savePath
' 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
Else
' La pièce jointe existe déjà sur la clé USB, ne rien faire dans ce cas
MsgBox "La pièce jointe '" & newFileName & "' existe déjà sur la clé USB."
End If
' Dans les 2 cas (enregistrée ou déjà présente sur la clé USB), la pièce jointe a été traitée
Set foundEmail = olItem
End If
Next olAttachment
End If
End If
End If
' Sortir de la boucle externe 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
' Afficher un message si aucune pièce jointe n'a été trouvée
If foundEmail Is Nothing Then
MsgBox "Aucun e-mail trouvé avec la pièce jointe '" & attachmentName & "' de l'expéditeur '" & senderEmail & "'."
End If
Set foundEmail = Nothing
End SubCdlt,
Cylfo
Bonjour Cylfo,
Bon j'ai pris en compte tes conseils. J'avais retravaillé sur le code en voici le résultat :
Je pense m'arrêter là je ne vois pas ce que je peux plus optimiser en plus de ce que tu m'a fourni dans ton dernier mail (non visible dans le code ci-dessous mais appliqué)
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 ReceivedTime As Integer
' Chemin du dossier où enregistrer la pièce jointe sur la clé USB
saveFolder = "G:\USB -VAC WSV - SNLE\MAJ CYCLE\" & Format(Date, "mm") & " - " & UCase(Format(Date, "mmmm")) & "\" & Format(Date, "ddmmyyyy") & "\"
'Ouvrir le dossier saveFolder
Shell "explorer.exe " & Chr(34) & saveFolder & Chr(34), vbNormalFocus
' Adresse e-mail de l'expéditeur à rechercher (serveur Exchange)
senderEmail = "jacques.trans@ADCOFOST.MARINE.DEFENSECDD.GOUV.FR" ' Modifier selon l'adresse e-mail de l'expéditeur
' Nom de la pièce jointe à rechercher
attachmentName = "6WW.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
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
Set foundEmail = Nothing
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
' Vérifier si l'e-mail a déjà été traité et enregistré
If Not olItem.UnRead Then
MsgBox "Le mail de l'expéditeur a déja été lu/traité, la pièce jointe a déjà été enregistrée sur la clé USB."
Exit Sub
End If
' 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
' Vérifier si le fichier existe déjà sur la clé USB
If Not FileExistsOnUSB(savePath) Then
' Enregistrer la pièce jointe sur la clé USB
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 = "6WW - 1430z.txt"
ElseIf (olItem.ReceivedTime >= dCejour18h00 And olItem.ReceivedTime <= dCejour20h00) Then
newFileName = "6WW - 2030z.txt"
End If
' Renommer le fichier après l'avoir enregistré
Name savePath As saveFolder & newFileName
MsgBox "La pièce jointe a bien été enregistrée"
' 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
Else
' La pièce jointe existe déjà sur la clé USB, ne rien faire dans ce cas
MsgBox "La pièce jointe '" & attachmentName & "' existe déjà sur la clé USB."
End If
End If
Next olAttachment
End If
End If
' Sortir de la boucle externe 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
' Afficher un message si aucune pièce jointe n'a été trouvée
If foundEmail Is Nothing Then
MsgBox "Aucun e-mail trouvé avec la pièce jointe '" & attachmentName & "' de l'expéditeur '" & senderEmail & "'."
End If
Set foundEmail = Nothing
End Sub
Function FileExistsOnUSB(saveFolder As String) As Boolean
' Vérifie si un fichier existe sur la clé USB à l'emplacement spécifié
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
FileExistsOnUSB = fso.FileExists(saveFolder)
Set fso = Nothing
End FunctionC
D'accord, n'oublies pas de clôturer le sujet