FAQ Outlook - Articles: R15200 [VBA] Enregistrer en .msg

Enregistre le mail, le contact, la tâche ou le rdv en cours en fichier .msg dans un dossier de l'explorateur.

Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
'By Oliv' juillet 2007 pour OUTLOOK 2003

If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem

'Ici on construit le nom du fichier qui sera créé
NomExport = objCurrentMessage.Subject & objCurrentMessage.CreationTime

'Ici on définit le répertoire où l'enregistrer
repertoire = "c:\temp\"
'repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"

'Ici on supprime les caractères non autorisés dans les noms de fichiers
PathNomExport = repertoire & "Email " & 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

Sub LanceSurOuvert()
sav_mail_as_msg
End Sub

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

Il faut exécuter LanceSurOuvert à partir de l'élément ouvert ou LanceSurSelection à partir d'une sélection d'éléments.

Pour choisir directement le dossier où enregistrer le fichier copié
dans un autre module ou avant la macro ci-dessus la fonction BrowseForFolder se trouvant là :

http://www.c2i.fr/code.asp?IDCode=1083