VBA: OutlookのメールをExcelにオブジェクトとして挿入する

Sub InsertMail()
    ' 現在Outlookで選択しているメールをExcelの選択しているセルに「オブジェクトの挿入」で挿入

    Dim objMail As Outlook.MailItem
    Dim fileName As String
    Dim filePath As String
    Dim folderPath As String
    Dim outlookApp As Outlook.Application

    ' Outlookで選択しているメールを取得
    On Error Resume Next
    Set outlookApp = GetObject(, "Outlook.Application")
    Set objMail = outlookApp.ActiveExplorer.Selection(1)
    On Error GoTo 0

    If objMail Is Nothing Then
        MsgBox "Outlookでメールが選択されていません。", vbExclamation
        Exit Sub
    End If


    ' メールを保存
    folderPath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\InsertMail"
    mailTitle = objMail.Subject
    fileName = Replace(Replace(mailTitle, ":", "："), "\", "￥") & ".msg"
    If Dir(folderPath, vbDirectory) = "" Then
        MkDir folderPath
    End If
    filePath = folderPath & "\" & fileName
    objMail.SaveAs (filePath)


    ' Outlookメールをオブジェクトとして挿入
    ThisWorkbook.ActiveSheet.OLEObjects.Add( _
        fileName:=filePath, _
        Link:=False, _
        DisplayAsIcon:=True _
    ).Select

End Sub