VBA批量导入.msg邮件到Excel时发件人/正文等字段为空的问题求助

• 本地文件夹存储数千份MS Outlook格式的.msg邮件文件，需要通过VBA生成Excel电子表格，提取每封邮件的以下指定信息：
  • 邮件发送时间
  • 发件人邮箱地址
  • 收件人邮箱地址
  • 邮件主题
  • 邮件正文
  • 附件数量
  • msg文件名
  • 文件存储路径
• 原有VBA脚本运行时，发件人邮箱、收件人邮箱、邮件正文对应的单元格始终为空白，无法正常填充数据，原脚本如下：

Sub import_msg_files()

' Turn off alerts etc

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

' Define Variables

Dim i As Long
Dim inPath As String
Dim thisFile As String
Dim Msg As MailItem
Dim ws As Worksheet
Dim myOlApp As Outlook.Application
Dim MyItem As Outlook.MailItem

Set myOlApp = CreateObject("Outlook.Application")

' Allow User to Select Folder contain emails

With Application.FileDialog(msoFileDialogFolderPicker)
   .AllowMultiSelect = False
        If .Show = False Then
            Exit Sub
        End If
    On Error Resume Next
    inPath = .SelectedItems(1) & "\"
End With
      
' Create a new worksheet and give it headers in row 1

Sheets.Add After:=ActiveSheet
Set ws = ThisWorkbook.ActiveSheet

ws.Cells(1, 1) = "Sent Date/Time"
ws.Cells(1, 2) = "Senders Email Address"
ws.Cells(1, 3) = "Email Sent To"
ws.Cells(1, 4) = "Subject"
ws.Cells(1, 5) = "Body"
ws.Cells(1, 6) = "Attachments Count"
ws.Cells(1, 7) = "Filename"
ws.Cells(1, 8) = "Folder"

' Starting on row two, begin looping through the .msg files in the folder selected and populating cells with the relevant data from each .msg file.
' New row for each .msg file.

thisFile = Dir(inPath & "*.msg")
i = 2

Do While thisFile <> ""
    Set MyItem = myOlApp.CreateItemFromTemplate(inPath & thisFile)
    ws.Cells(i, 1) = MyItem.SentOn
    ws.Cells(i, 2) = MyItem.Sender
    ws.Cells(i, 3) = MyItem.To
    ws.Cells(i, 4) = MyItem.Subject
    ws.Cells(i, 5) = MyItem.Body
    ws.Cells(i, 6) = MyItem.Attachments.Count
    ws.Cells(i, 7) = thisFile
    ws.Cells(i, 8) = inPath
    i = i + 1
    thisFile = Dir()
Loop

'Clear mind and start reading emails.

Set MyItem = Nothing
Set myOlApp = Nothing

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

• 核心问题是使用CreateItemFromTemplate方法读取本地msg文件：该方法设计用途是基于模板创建新的待发送邮件，加载本地msg时会自动忽略发件人、收件人、传输相关的正文头部属性，属于Outlook对象模型的默认行为，不是属性调用错误。
• 属性调用错误：MyItem.Sender返回的是AddressEntry对象，不是字符串类型的邮箱地址，直接赋值给单元格无法得到有效文本；MyItem.To返回的是收件人显示名称，不是实际邮箱地址，遇到内部Exchange账号时经常返回空值。
• 全局On Error Resume Next吞掉了所有属性读取的报错信息，没有抛出异常，直接表现为对应单元格留空。
• 未做对象释放，批量读取时容易触发Outlook内存占用过高，进一步导致属性加载失败。

1. 替换文件打开方法：使用NameSpace.OpenSharedItem方法读取本地msg文件，该方法是官方提供的专门用于打开独立共享项（msg、ics、vcf等）的接口，能完整加载所有邮件属性。
2. 修正邮箱地址提取逻辑：
   • 发件人地址优先取SenderEmailAddress属性，遇到Exchange类型的内部发件人，通过GetExchangeUser接口提取实际SMTP地址
   • 收件人地址遍历Recipients集合提取，同样兼容Exchange类型收件人，多个收件人用分号分隔
3. 移除全局错误忽略，仅在可能出现兼容问题的单行做错误捕获，避免无提示失效。
4. 每次读取完单个邮件后主动关闭并释放对象，避免Outlook进程残留。

修复后的完整可运行代码如下：

Sub import_msg_files()
    ' 关闭界面更新提升运行效率
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    ' 变量定义
    Dim i As Long
    Dim inPath As String
    Dim thisFile As String
    Dim ws As Worksheet
    Dim myOlApp As Object
    Dim myNamespace As Object
    Dim MyItem As Object
    Dim recip As Object
    Dim senderAddr As String
    Dim toAddr As String
    Dim exUser As Object

    ' 初始化Outlook应用，优先复用已打开的Outlook进程
    On Error Resume Next
    Set myOlApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set myOlApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    myNamespace.Logon , , True, False

    ' 选择邮件存储文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = False Then GoTo Cleanup
        inPath = .SelectedItems(1) & "\"
    End With
      
    ' 新建工作表写入表头
    Sheets.Add After:=ActiveSheet
    Set ws = ThisWorkbook.ActiveSheet
    ws.Cells(1, 1) = "Sent Date/Time"
    ws.Cells(1, 2) = "Senders Email Address"
    ws.Cells(1, 3) = "Email Sent To"
    ws.Cells(1, 4) = "Subject"
    ws.Cells(1, 5) = "Body"
    ws.Cells(1, 6) = "Attachments Count"
    ws.Cells(1, 7) = "Filename"
    ws.Cells(1, 8) = "Folder"

    ' 遍历所有msg文件提取数据
    thisFile = Dir(inPath & "*.msg")
    i = 2
    Do While thisFile <> ""
        ' 完整加载本地msg文件
        Set MyItem = myNamespace.OpenSharedItem(inPath & thisFile)
        
        ' 提取发件人SMTP地址，兼容Exchange内部账号
        senderAddr = ""
        If MyItem.SenderEmailType = "EX" Then
            On Error Resume Next
            Set exUser = MyItem.Sender.GetExchangeUser
            If Not exUser Is Nothing Then senderAddr = exUser.PrimarySmtpAddress
            On Error GoTo 0
        Else
            senderAddr = MyItem.SenderEmailAddress
        End If
        
        ' 提取所有收件人SMTP地址
        toAddr = ""
        For Each recip In MyItem.Recipients
            If recip.Type = 1 Then ' 仅提取主送收件人，需抄送/密送可增加Type=2/3的判断
                If recip.AddressEntry.Type = "EX" Then
                    On Error Resume Next
                    Set exUser = recip.AddressEntry.GetExchangeUser
                    If Not exUser Is Nothing Then toAddr = toAddr & exUser.PrimarySmtpAddress & ";"
                    On Error GoTo 0
                Else
                    toAddr = toAddr & recip.Address & ";"
                End If
            End If
        Next
        ' 移除末尾多余分隔符
        If Len(toAddr) > 0 Then toAddr = Left(toAddr, Len(toAddr) - 1)
        
        ' 数据写入工作表
        ws.Cells(i, 1) = MyItem.SentOn
        ws.Cells(i, 2) = senderAddr
        ws.Cells(i, 3) = toAddr
        ws.Cells(i, 4) = MyItem.Subject
        ws.Cells(i, 5) = MyItem.Body
        ws.Cells(i, 6) = MyItem.Attachments.Count
        ws.Cells(i, 7) = thisFile
        ws.Cells(i, 8) = inPath
        
        ' 关闭当前邮件、释放对象
        MyItem.Close 1 ' 不保存任何修改
        Set MyItem = Nothing
        
        i = i + 1
        thisFile = Dir()
    Loop

    ' 自动调整列宽
    ws.UsedRange.EntireColumn.AutoFit

Cleanup:
    ' 释放所有对象，恢复Excel默认设置
    Set recip = Nothing
    Set exUser = Nothing
    Set MyItem = Nothing
    Set myNamespace = Nothing
    Set myOlApp = Nothing
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

• 代码使用晚绑定方式调用Outlook对象，不需要手动添加Outlook对象库引用，兼容所有版本的Office。
• 运行前请确保Outlook已经完成初始配置，能正常打开进入主界面。
• 如果需要提取HTML格式的富文本正文，将MyItem.Body替换为MyItem.HTMLBody即可；需要提取附件保存路径的话，可以遍历MyItem.Attachments集合逐个保存文件后记录路径。
• 批量处理数千份邮件时不要中途强制终止宏，若出现Outlook后台残留，可打开任务管理器结束残留的OUTLOOK.EXE进程。

内容的提问来源于stack exchange，提问作者Myers