Option Explicit
Public Sub SaveMessageAsMsg()
    Dim oMail As Outlook.MailItem
    Dim objItem As Object
    Dim sPath, strFolderpath As String
    Dim dtDate As Date
    Dim sName As String
    Dim sPathsName As String
    Dim sExp As String
    Dim enviro As String
    On Error GoTo FinErreur
    
    ' Arborescence par défaut lors de l'ouverture de BrowseForFolder
    enviro = CStr(Environ("USERPROFILE"))
    strFolderpath = BrowseForFolder(enviro & "\Box Sync\xxxxxxx\Documents\Management_xx\")
    
    ' Boucle de copie des messages sélectionnés dans outlook "Format jour-mois-année_heure-min_nom,exp_objet du message.msg"
    For Each objItem In ActiveExplorer.Selection
    If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem
    
    sName = oMail.Subject
    sExp = oMail.SenderName
    ReplaceCharsForFileName sName, "-"
    
    dtDate = oMail.ReceivedTime
    sName = Format(dtDate, "dd-mm-yyyy", vbUseSystemDayOfWeek, _
            vbUseSystem) & Format(dtDate, "_h\Hmm", _
            vbUseSystemDayOfWeek, vbUseSystem) & "_" & sExp & "_" & sName & ".msg"
    
    sPath = strFolderpath & "\"
    sPathsName = sPath & sName
    ' Tronque sPathsName à 255 caractéres, sinon erreur de copie oMail.SaveAs
    sPathsName = Left(sPathsName, 255) & Right(sPathsName, 4)
    Debug.Print sPath & sName
    oMail.SaveAs sPathsName, olMsg
  
    End If
    Next
    MsgBox "Copié(s) dans répertoire"
    Exit Sub
    
FinErreur:
    MsgBox Err.Description
    
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
    sChr As String _
    )
    sName = Replace(sName, "'", sChr)
    sName = Replace(sName, "*", sChr)
    sName = Replace(sName, "/", sChr)
    sName = Replace(sName, "\", sChr)
    sName = Replace(sName, ":", sChr)
    sName = Replace(sName, "?", sChr)
    sName = Replace(sName, Chr(34), sChr)
    sName = Replace(sName, "<", sChr)
    sName = Replace(sName, ">", sChr)
    sName = Replace(sName, "|", sChr)
 
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    Dim ShellApp As Object
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
 
    
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

    Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
Exit Function

Invalid:
    BrowseForFolder = False
    MsgBox "Repertoire invalide"
End Function