修改Outlook邮件导入Excel的VBA代码需求咨询

Sub GetFromOutlook()
    Dim OutlookApp As Outlook.Application
    Dim OutlookNamespace As Namespace
    Dim SourceFolder As MAPIFolder
    Dim TargetFolder As MAPIFolder
    Dim OutlookMail As MailItem
    Dim i As Integer
    Dim TeamMailboxName As String
    
    ' 替换为你的团队邮箱显示名称
    TeamMailboxName = "团队邮箱名称"
    
    Set OutlookApp = New Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
    
    ' 定位团队邮箱的Procedures文件夹
    On Error Resume Next
    Set SourceFolder = OutlookNamespace.Folders(TeamMailboxName).Folders("收件箱").Folders("Comms").Folders("Procedures")
    On Error GoTo 0
    If SourceFolder Is Nothing Then
        MsgBox "未找到指定的团队邮箱文件夹，请检查名称是否正确", vbExclamation
        GoTo Cleanup
    End If
    
    ' 定位目标文件夹（Procedures下的imported）
    On Error Resume Next
    Set TargetFolder = SourceFolder.Folders("imported")
    On Error GoTo 0
    If TargetFolder Is Nothing Then
        MsgBox "未找到imported文件夹，请先创建", vbExclamation
        GoTo Cleanup
    End If
    
    i = 1
    
    ' 遍历邮件时筛选MailItem类型，避免非邮件项报错
    For Each OutlookMail In SourceFolder.Items
        If TypeName(OutlookMail) = "MailItem" Then
            If OutlookMail.ReceivedTime >= Range("From_date").Value Then
                ' 写入邮件基础信息
                Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
                Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
                Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName
                Range("eMail_text").Offset(i, 0).Value = OutlookMail.Body
                
                ' 稳定获取SMTP邮箱地址
                If OutlookMail.SenderEmailType = "EX" Then
                    ' 处理Exchange域内用户
                    Dim exchUser As ExchangeUser
                    Set exchUser = OutlookMail.Sender.GetExchangeUser
                    If Not exchUser Is Nothing Then
                        Range("eMail_senderaddress").Offset(i, 0).Value = exchUser.PrimarySmtpAddress
                    Else
                        Range("eMail_senderaddress").Offset(i, 0).Value = OutlookMail.SenderEmailAddress
                    End If
                Else
                    ' 直接读取SMTP地址
                    Range("eMail_senderaddress").Offset(i, 0).Value = OutlookMail.SenderEmailAddress
                End If
                
                i = i + 1
                
                ' 将已导入邮件移动到imported文件夹
                OutlookMail.Move TargetFolder
            End If
        End If
    Next OutlookMail

Cleanup:
    Set TargetFolder = Nothing
    Set SourceFolder = Nothing
    Set OutlookNamespace = Nothing
    Set OutlookApp = Nothing
End Sub

关键修改说明 #

1. 切换到团队邮箱文件夹 #

• 通过OutlookNamespace.Folders(TeamMailboxName)定位团队邮箱根目录，需将TeamMailboxName替换为实际的团队邮箱显示名称（如"运营部共享邮箱"）
• 保持原有的"收件箱→Comms→Procedures"层级结构，确保与团队邮箱内的文件夹路径一致
• 添加文件夹存在性检查，避免因路径错误导致代码崩溃

2. 稳定获取SMTP邮箱地址 #

• 区分Exchange域内用户与普通SMTP用户：
  • Exchange用户通过Sender.GetExchangeUser.PrimarySmtpAddress获取真实SMTP地址，解决原代码返回内部EX格式地址的问题
  • 非Exchange用户直接读取SenderEmailAddress
• 增加空值判断，防止获取Exchange用户信息失败时出现报错

3. 导入后移动邮件到imported文件夹 #

• 先定位Procedures文件夹下的imported子文件夹
• 在单封邮件处理完成后，调用OutlookMail.Move TargetFolder完成移动操作
• 同样添加文件夹存在性检查，确保移动操作有效执行

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