无法打开.msg文件

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

我如何允许打开.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