使用 vba 选择特定电子邮件上的文件夹

Question

我在 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

我尝试了以下代码，但收到以下消息：

对象不支持该属性或方法

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

最后代码如下并且可以正常工作：

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

Answer 1

首先，我注意到您遍历文件夹中的所有项目，这并不是一个好主意。相反，您需要使用 Items 类的 Find/FindNext 或 Restrict 方法来获取与您的条件相对应的项目。在以下文章中阅读有关这些方法的更多信息：

• How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
• How To: Use Restrict method to retrieve Outlook mail items from a folder

您还可以将两个条件组合成一个条件。要查找带有附件的项目，您可以使用以下搜索条件：

query ="@SQL=" & chr(34) & "urn:schemas:httpmail:hasattachment" & chr(34) & "=1"

要遍历配置文件中的所有商店，您可以使用Stores 属性，该属性返回代表当前配置文件中所有Store 对象的Stores 集合对象。 Store.DisplayName 属性返回一个字符串，表示Store 对象的显示名称。例如：

Sub EnumerateFoldersInStores() 
 Dim colStores As Outlook.Stores
 Dim oStore As Outlook.Store 
 Dim oRoot As Outlook.Folder 
 
 On Error Resume Next 
 Set colStores = Application.Session.Stores
 For Each oStore In colStores 
   Set oRoot = oStore.GetRootFolder 
   Debug.Print (oRoot.FolderPath) 
   EnumerateFolders oRoot 
 Next 
End Sub 
 
Private Sub EnumerateFolders(ByVal oFolder As Outlook.Folder) 
 Dim folders As Outlook.folders 
 Dim Folder As Outlook.Folder 
 Dim foldercount As Integer 
 
 On Error Resume Next 
 
 Set folders = oFolder.folders 
 foldercount = folders.Count 
 'Check if there are any folders below oFolder 
 If foldercount Then 
   For Each Folder In folders 
     Debug.Print (Folder.FolderPath) 
     EnumerateFolders Folder 
   Next 
 End If 
End Sub