无法打开.msg文件

Question

我有大约90个.msg，我需要打开的Outlook文件，将excel附件转换为.csv文件并保存。目前，下面的代码只是打开.msg outlook文件，但出现错误：

如何允许打开.msg文件。

脚本：

Sub OpenMSGRenameDownloadAttachement()

    Dim objOL As Outlook.Application
    Dim Msg As Outlook.MailItem

    Dim MsgCount As Integer

    Set objOL = CreateObject("Outlook.Application")

    'Change the path given month, ie. do this for Jan, Feb, April
    inPath = "C:\January Messages"

    thisFile = LCase(Dir(inPath & "\*.msg"))
    Do While thisFile <> ""

        Set Msg = objOL.Session.OpenSharedItem(thisFile)

        Msg.Display

        MsgBox Msg.Subject
        thisFile = Dir
    Loop

    Set objOL = Nothing
    Set Msg = Nothing

End Sub

Answer 1

试试这个：

Sub OpenMSGRenameDownloadAttachement()
Dim Msg As Outlook.MailItem
Dim objAtt As Outlook.Attachment
Set objOL = CreateObject("Outlook.Application")
Set objNs = objOL.GetNamespace("MAPI")
'objNs.Logon

inPath = "C:\January Messages\"
outPath = "C:\January Messages\attachments\" 'create this folder for attachments or use your own
thisFile = Dir(inPath & "*.msg")

Do While Len(thisFile) > 0
    Set Msg = objNs.OpenSharedItem(inPath & thisFile)
    'MsgBox inPath & thisFile
    'MsgBox Msg.Subject
    'MsgBox Msg.SenderEmailAddress
    'MsgBox Msg.Recipients.Item(1).Address
    For Each objAtt In Msg.Attachments
        If Right(objAtt, 4) = "xlsx" Or Right(objAtt, 3) = "xls" Then
            objAtt.SaveAsFile outPath & Split(objAtt.DisplayName, ".")(0) & ".csv"
        End If
    Next
    thisFile = Dir
Loop

Set objOL = Nothing
Set objNs = Nothing
End Sub