Code sav_mail_as_msg

Bonjour,

Je souhaiterais faire une macro afin d'enregistre mes mails sous un certain format, malheurement Excel ne reconnais pas ma fonction sav_mail_as_msg.

Est-ce que quelqu'un aurait une solution ?

Merci par avance,

Cordialement,

Sub sav_mail_as_msg(Optional objCurrentMessage As Object)

'    If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem

    'Ici on construit le nom du fichier qui sera créé

    Datemail = Mid(objCurrentMessage.CreationTime, 7, 4) & "_" & Mid(objCurrentMessage.CreationTime, 4, 2) & "_" & Mid(objCurrentMessage.CreationTime, 1, 2) & "_" & _
               Mid(objCurrentMessage.CreationTime, 12, 2) & "_" & Mid(objCurrentMessage.CreationTime, 15, 2) & "_" & Mid(objCurrentMessage.CreationTime, 18, 2)

    If objCurrentMessage.Subject = "" Then
        NomExport = Datemail & "_" & objCurrentMessage.SenderName
    Else
        NomExport = Datemail & "_" & objCurrentMessage.Subject
    End If

    'Ici on défini le répertoire où l'enregistrer
    repertoire = "C:\Travail\Cockpit Test\"
    'repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"

    'Ici on supprime les caractères non autorisé dans les noms de fichiers
    PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
    NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 220) & ".msg"

    'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
    n = 1
    MemPath = PathNomExport

    On Error GoTo Handle_error_file
    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
    Exit Sub

Handle_error_file:
     On Error GoTo Handle_error_file_2
    NomExport = Datemail & "_" & objCurrentMessage.SenderName

    PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
    NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 220) & ".msg"

    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
    Exit Sub

Handle_error_file_2:

    NomExport = Datemail & "_ Objet et expéditeur incorrect"

    PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
    NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 220) & ".msg"

    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 LanceSurSelection(MyMail As MailItem)
    Dim MonOutlook As Outlook.Application
    Dim LeMail As Object
    Dim LesMails As Outlook.Selection
    Dim oFldr As Outlook.MAPIFolder
    Set MonOutlook = Outlook.Application
    Dim NbMail As Integer

    Set LesMails = MonOutlook.ActiveExplorer.Selection

    NbMail = 0
    For Each LeMail In LesMails
        sav_mail_as_msg LeMail
        NbMail = NbMail + 1
    Next LeMail

    Set LesMails = Nothing