使用VBA选定Outlook指定邮箱账号下的文件夹的实现方案

需求背景 #

在Outlook中配置了多个邮箱账号时，原生默认代码仅能读取主账号的收件箱，需要实现读取指定邮箱账号下的文件夹内容。

原有仅支持主账号的代码 #

Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.GetDefaultFolder(olFolderInbox)

If Not outFolder Is Nothing Then
    For Each outItem In outFolder.Items
        If outItem.Class = Outlook.OlObjectClass.olMail Then
            Set outMailItem = outItem

            If InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilter

                For Each outAttachment In outMailItem.Attachments
                    If Dir(saveFolder, vbDirectory) = "" Then FSO.CreateFolder (saveFolder)
                    outAttachment.SaveAsFile saveFolder & " - " & outAttachment.fileName
                    Set outAttachment = Nothing
                Next

            End If
        End If
    Next
End If

错误尝试与报错 #

编写的遍历Stores的代码运行时报错：

对象不支持该属性或方法

错误代码如下：

For Each objStore In Application.Session.Stores
    If objStore = "++++++@o+++++.com" Then
    
        Set outNs = outApp.GetNamespace("MAPI")
        Set outFolder = outNs.GetDefaultFolder(olFolderInbox)
    
        If Not outFolder Is Nothing Then
            For Each outItem In outFolder.Items
                If outItem.Class = Outlook.OlObjectClass.olMail Then
                    Set outMailItem = outItem
                        If InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilter
                            For Each outAttachment In outMailItem.Attachments
                            If Dir(saveFolder, vbDirectory) = "" Then FSO.CreateFolder (saveFolder)
                                outAttachment.SaveAsFile saveFolder & outAttachment.Filename
                            Set outAttachment = Nothing
                            Next
                        End If
                End If
            Next
        End If
    End If
Next

错误原因

• 直接将objStore对象和邮箱字符串对比，没有取对象的属性值匹配，正确写法应该是判断objStore.SmtpAddress = "目标邮箱地址"
• 匹配到对应账号的Store后，仍然调用了命名空间的GetDefaultFolder方法，获取的还是主账号的收件箱，没有使用匹配到的Store获取对应文件夹

最终可运行的正确代码 #

Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.Folders("+++++++++++@+++++.com").Folders("Inbox") 'GetDefaultFolder(olFolderInbox)

If Not outFolder Is Nothing Then
    For Each outItem In outFolder.Items
        If outItem.Class = Outlook.OlObjectClass.olMail Then
            Set outMailItem = outItem
            If InStr(1, outMailItem.Subject, subjectFilter) > 0 Then 'removed the quotes around subjectFilter
                For Each outAttachment In outMailItem.Attachments
                    If Dir(saveFolder, vbDirectory) = "" Then FSO.CreateFolder (saveFolder)
                    outAttachment.SaveAsFile saveFolder & outAttachment.Filename
                    Set outAttachment = Nothing
                Next
            End If
        End If
    Next
End If

实现说明

直接通过MAPI命名空间的Folders集合，先按邮箱账号全称定位到目标账号根目录，再嵌套调用Folders("Inbox")定位到目标账号的收件箱，即可绕过主账号限制，直接读取指定账号的收件箱邮件内容。

内容的提问来源于stack exchange，提问作者Alejandro González Ponce