AReS097
Messages postés24Date d'inscriptionmercredi 11 mars 2009StatutMembreDernière intervention14 janvier 2021
-
Modifié le 10 févr. 2020 à 16:22
vb95
Messages postés3417Date d'inscriptionsamedi 11 janvier 2014StatutContributeurDernière intervention20 mai 2023
-
11 févr. 2020 à 23:13
Bonjour a tous,
J'ai créer une Macro VBA dans Outlook pour permettre au utilisateur de ranger leur Mail dans des dossier spécifique propre a notre process, et cette macro marche très bien.
Toutefois je n'arrive pas a résoudre un point qui me parait bête et pourtant je ne trouve pas de solution, c'est que une fois le mail enregistrer dans le dossier, je voudrais le mettre dans le dossier "Élément supprimée de Outlook", j'ai essayer plusieurs solution sans succès, pourriez vous me venir en aide ?
Merci par avance
Voici mon code :
__________
Private Sub LanceSurSelection()
Dim MonOutlook As Outlook.Application
Dim LeMail As Object
Dim LesMails As Outlook.Selection
Set MonOutlook = Outlook.Application
Set LesMails = MonOutlook.ActiveExplorer.Selection
For Each LeMail In LesMails
sav_mail_as_msg LeMail
Next LeMail
Set LesMails = Nothing
'MsgBox "Fin de traitement"
End Sub
__________
Private Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
'Extraction et formatage de la date
Annee = Mid(objCurrentMessage.CreationTime, 7, 4)
Mois = Mid(objCurrentMessage.CreationTime, 4, 2)
Jour = Mid(objCurrentMessage.CreationTime, 1, 2)
Heure = Mid(objCurrentMessage.CreationTime, 12, 5)
'Ici on construit le nom du fichier qui sera créé
NomExport = Annee & Mois & Jour & "-" & Heure & "-" & MailSens & " - " & objCurrentMessage.Subject
'Ici on défini le répertoire où l'enregistrer
'repertoire = "c:\Cmc Interface\"
'repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"
'Ici on supprime les caractères non autorisé dans les noms de fichiers
PathNomExport = RepArchiv & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
NomExport, "\", " "), "/", " "), ":", ""), "*", " "), "?", " "), "<", " "), ">", " "), "|", " "), ".", " "), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
n = 1
MemPath = PathNomExport
While Dir(PathNomExport) <> ""
MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
n = n + 1
Wend
objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG
End Sub