Excel VBA读取Outlook邮件遇连接错误，求代码修复方案

问题概述 #

使用Excel VBA编写代码，目标实现：

• 将收件箱未读邮件标记为已读
• 保存所有邮件附件
• 根据邮件主题自动回复特定重要邮件

但执行时，获取收件箱的代码行抛出「未连接」运行时错误。尝试修改变量类型、变量名、循环结构等方法后仍未解决，原代码如下：

Dim olInbox As Outlook.MAPIFolder
Dim myInbox As Outlook.Folder 'does not change error if we switch this to object
Dim unRead, m As Object
Dim att As Object
Dim emailSubject As String
Dim newEmailItem As Outlook.MailItem
Dim x As Date
Dim ws As Worksheet
Dim i As Long
Dim row As Long
Dim unk As Integer

x = Date

'~~> Get Outlook instance
Set EmailApp = New Outlook.Application
Set myNameSpace = Outlook.GetNamespace("MAPI")
'For unk = 1 To 2 Step 1
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folder 'HERE IS WHERE MY ERROR IS
        'using "olInbox" in place of "myInbox" does not solve it either so its not expecting a MAPI

    'Set olInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders(myInbox.Name)
    'For i = olInbox.Items.Count To 1 Step -1
            'If TypeOf olInbox.Items(i) Is MailItem Then
                Set newEmailItem = olInbox.Items(i)
               ' If newEmailItem(newEmailItem.Subject, "transactions") > 0 _
               ' And newEmailItem(newEmailItem.ReceivedTime, x) > 0 Then
               '    With ws
               '        row = .Range("A" & .Rows.Count).End(xlUp).row
               '        .Range("A" & row).Offset(1, 0).Value = newEmailItem.Subject
               '        .Range("A" & row).Offset(1, 1).Value = newEmailItem.ReceivedTime
               '        .Range("A" & row).Offset(1, 2).Value = newEmailItem.SenderName
               '     End With
               ' End If
            'End If
    'Next i
    'Set olInbox = Nothing
'Next unk or myInbox?

'set unread equal to the count of unread e mails in the inbox
Set unRead = myInbox.Items.Restrict("[UnRead] = True")

File_Path = "D:\Documents\Email attachments\" 'where we save the attachments

If unRead.Count = 0 Then
    MsgBox "NO Unread Email In Inbox"

Else
    For Each m In unRead
        emailSubject = newEmailItem.Subject

        Select Case emailSubject

        Case emailSubject Like "MOI"

            Set newEmailItem = EmailApp.CreateItem(olMailItem) 'creates a new e mail to be sent
            newEmailItem.To = "chase.bcbengineering@gmail.com" 'who your sending it to, we will need     to make dynamic
            newEmailItem.Subject = "MOI" 'enters MOI into new e mail subject line"

            'below is the body of the e mail
            newEmailItem.HTMLBody = "Hi," & vbNewLine & "Branagan Ins here just wanted to let you know     there is a new MOI" & vbNewLine & "have a great week" & vbNewLine & "Branagan Ins Services" & vbNewLine & "707-255-2500" & vbNewLine & "Marilyn Branagan" & vbNewLine & "1631 Lincoln ave, Napa CA"

            If m.Attachments.Count > 0 Then
                For Each att In m.Attachments
                    att.SaveAsFile File_Path & "att.Filename" 'might need to make dynamic
                    m.unRead = False 'mark email as read
                    DoEvents
                    m.Save
                    EmailApp.Attachments.Add File_Path & "att.Filename" 'attach att to new e mail out
                Next att
            End If
          
            newEmailItem.Send
          
        Case emailSubject Like "Renewal"

            Set newEmailItem = EmailApp.CreateItem(olMailItem) 'creates a new e mail to be sent
            newEmailItem.To = "chase.bcbengineering@gmail.com" 'who your sending it to, we will need to make dynamic
            newEmailItem.Subject = "Renewal" 'enters MOI into new e mail subject line"

            'below is the body of the e mail
            newEmailItem.HTMLBody = "Hi," & vbNewLine & "Branagan Ins here just wanted to let you know     your policy is renewing" & vbNewLine & "have a great week" & vbNewLine & "Branagan Ins Services" & vbNewLine & "707-255-2500" & vbNewLine & "Marilyn Branagan" & vbNewLine & "1631 Lincoln ave, Napa CA"

            If m.Attachments.Count > 0 Then
                For Each att In m.Attachments
            
                    MsgBox "you saved your attachements"
   
                    att.SaveAsFile File_Path & "att.Filename" 'might need to make dynamic
                    m.unRead = False
                    DoEvents
                    m.Save
                    EmailApp.Attachments.Add File_Path & "att.Filename" 'attach att to new e mail out
                Next att
            End If
          
            newEmailItem.Send
          
        Case Else
            m.unRead = False 'marks all messages as read
        
        End Select
 
    Next m
End If
End Sub

错误原因分析 #

• 收件箱获取错误：myNameSpace.GetDefaultFolder(olFolderInbox)直接返回的就是Outlook收件箱的Folder对象，不需要额外添加.Folder属性，这是导致「未连接」错误的直接原因。
• 变量声明不规范：unRead, m As Object仅将m声明为Object类型，unRead默认是Variant，应明确声明为Outlook.Items类型，避免类型不匹配问题。
• 主题获取逻辑错误：循环中emailSubject = newEmailItem.Subject的newEmailItem未初始化，应使用当前遍历的邮件对象m来获取主题。
• 附件保存与添加错误：
  • att.SaveAsFile中的att.Filename未正确引用附件文件名，应改为att.FileName（注意大小写）。
  • 向新邮件添加附件时，错误调用EmailApp.Attachments.Add，应改为newEmailItem.Attachments.Add，因为附件属于邮件项而非应用程序。
• Select Case语法错误：原代码中Case emailSubject Like "MOI"写法错误，应使用Case Like "*MOI*"的格式来实现模糊匹配。

修正后的完整代码 #

Sub ProcessOutlookInbox()
    Dim myInbox As Outlook.Folder
    Dim unRead As Outlook.Items
    Dim m As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim emailSubject As String
    Dim newEmailItem As Outlook.MailItem
    Dim File_Path As String
    Dim ws As Worksheet ' 若需要写入Excel可取消注释并初始化
    
    ' 初始化保存路径
    File_Path = "D:\Documents\Email attachments\"
    ' 确保路径末尾有反斜杠
    If Right(File_Path, 1) <> "\" Then File_Path = File_Path & "\"
    
    ' 获取Outlook实例与命名空间
    Dim EmailApp As Outlook.Application
    Dim myNameSpace As Outlook.Namespace
    Set EmailApp = New Outlook.Application
    Set myNameSpace = EmailApp.GetNamespace("MAPI")
    
    ' 获取默认收件箱（修复核心错误）
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    
    ' 筛选未读邮件
    Set unRead = myInbox.Items.Restrict("[UnRead] = True")
    ' 按接收时间排序，避免遍历过程中顺序变动
    unRead.Sort "[ReceivedTime]", olDescending
    
    If unRead.Count = 0 Then
        MsgBox "收件箱中无未读邮件"
        GoTo Cleanup
    End If
    
    ' 遍历未读邮件
    For Each m In unRead
        emailSubject = m.Subject
        
        ' 标记当前邮件为已读（提前标记，避免重复处理）
        m.UnRead = False
        m.Save
        
        Select Case True
            Case emailSubject Like "*MOI*"
                ' 创建自动回复邮件
                Set newEmailItem = EmailApp.CreateItem(olMailItem)
                With newEmailItem
                    .To = "chase.bcbengineering@gmail.com"
                    .Subject = "MOI 通知"
                    .HTMLBody = "Hi,<br><br>Branagan Ins 告知您有新的 MOI 邮件。<br><br>祝您一周愉快<br>Branagan Ins Services<br>707-255-2500<br>Marilyn Branagan<br>1631 Lincoln ave, Napa CA"
                End With
                
                ' 保存附件并添加到回复邮件
                If m.Attachments.Count > 0 Then
                    For Each att In m.Attachments
                        att.SaveAsFile File_Path & att.FileName
                        newEmailItem.Attachments.Add File_Path & att.FileName
                    Next att
                End If
                
                ' 发送邮件
                newEmailItem.Send
                
            Case emailSubject Like "*Renewal*"
                ' 创建自动回复邮件
                Set newEmailItem = EmailApp.CreateItem(olMailItem)
                With newEmailItem
                    .To = "chase.bcbengineering@gmail.com"
                    .Subject = "保单续保通知"
                    .HTMLBody = "Hi,<br><br>Branagan Ins 告知您保单即将续保。<br><br>祝您一周愉快<br>Branagan Ins Services<br>707-255-2500<br>Marilyn Branagan<br>1631 Lincoln ave, Napa CA"
                End With
                
                ' 保存附件并添加到回复邮件
                If m.Attachments.Count > 0 Then
                    For Each att In m.Attachments
                        att.SaveAsFile File_Path & att.FileName
                        newEmailItem.Attachments.Add File_Path & att.FileName
                    Next att
                End If
                
                ' 发送邮件
                newEmailItem.Send
                
            Case Else
                ' 其他邮件仅标记为已读，无需回复
        End Select
        
        DoEvents ' 释放资源，避免卡顿
    Next m
    
    MsgBox "未读邮件处理完成"

Cleanup:
    ' 释放所有对象
    Set att = Nothing
    Set m = Nothing
    Set unRead = Nothing
    Set myInbox = Nothing
    Set myNameSpace = Nothing
    Set EmailApp = Nothing
End Sub

额外说明 #

• 若需要将邮件信息写入Excel工作表，可取消ws变量的注释，并在代码中添加初始化逻辑（如Set ws = ThisWorkbook.Sheets("Sheet1")）。
• 路径File_Path需确保存在，若不存在可添加创建文件夹的代码（If Dir(File_Path, vbDirectory) = "" Then MkDir File_Path）。
• 模糊匹配使用*通配符，可根据需求调整匹配规则（如*MOI*匹配包含MOI的主题，MOI*匹配以MOI开头的主题）。

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