展望VBA (365) vs 2010

Sub SaveACopy() 'ByVal Item As Object)  'Item As Object
    Const olMsg As Long = 3
    Dim m As MailItem
    Dim strPath As String
     Set m = GetCurrentItem
    If TypeName(m)  "MailItem" Then Exit Sub
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
Dim fd As Office.FileDialog
Set fd = xlApp.Application.FileDialog(msoFileDialogFolderPicker)
Dim selectedItem As Variant
If fd.Show = -1 Then
    For Each selectedItem In fd.SelectedItems
        Debug.Print selectedItem
        strPath = selectedItem
    Next
End If
Set fd = Nothing
    xlApp.Quit
Set xlApp = Nothing
Dim strSubject As String
strSubject = m.Subject
strSubject = Replace(strSubject, ":", "")
'strPath = """" & strPath
strPath = strPath & "" & strSubject
strPath = strPath & " " & Format(Now(), "ddmmmyyyy-hhNNss") '"yyyy-mm-dd-hhnnss"    YYYY-mm-dd
strPath = strPath & ".msg"
strPath = strPath '& """"
m.SaveAs strPath, olMsg
m.Close olDiscard
End Sub
'Set objItem = objApp.ActiveExplorer.Selection.Item(1)
Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application  
    Set objApp = Application
    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    End Select
    Set objApp = Nothing
End Function