Question

我正在尝试在VBA for Outlook 2013中将主题中具有特定数字格式的任何邮件排序到相应的文件夹中。如果该文件夹不存在（如果主题和文件夹中的字符串不匹配），则创建该文件夹。我需要这个宏来处理非默认的收件箱。以下链接是我获得原始代码的地方，它在底部拼接在一起。我在线上遇到了运行时错误（-2147221233（8004010f））：

Set objProjectFolder = objDestinationFolder.Folders(folderName)

http://joelslowik.blogspot.com/2011/04/sort-emails-in-outlook-using-macro-and.html

Get email from non default inbox?

Dim WithEvents myitems As Outlook.Items
Dim objDestinationFolder As Outlook.MAPIFolder

Sub Application_Startup()

Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim strFilter As String

' let the user choose which account to use
Set myAccounts = Application.GetNamespace("MAPI").Stores
For i = 1 To myAccounts.Count
    res = MsgBox(myAccounts.Item(i).DisplayName & "?", vbYesNo)
    If res = vbYes Then
        Set myInbox = myAccounts.Item(i).GetDefaultFolder(olFolderInbox)
        Exit For
    End If
Next
If myInbox Is Nothing Then Exit Sub ' avoid error if no account is chosen
Set objDestinationFolder = myInbox.Parent.Folders("Inbox")

For Count = myInbox.Items.Count To 1 Step -1
    Call myitems_ItemAdd(myInbox.Items.Item(Count))
Next Count
StopRule

End Sub

' Run this code to stop your rule.
Sub StopRule()
Set myitems = Nothing
End Sub

' This code is the actual rule.
Private Sub myitems_ItemAdd(ByVal Item As Object)

Dim objProjectFolder As Outlook.MAPIFolder
Dim folderName As String

' Search for email subjects that contain a case number
' Subject line must have the sequence of 4 numbers + - + 3 numbers (CPS case number syntax)
   Set objRegEx = CreateObject("VBScript.RegExp")
   objRegEx.Global = False
   objRegEx.Pattern = "[0-9]{4,4}\-?[0-9]{0,3}"
   Set colMatches = objRegEx.Execute(Item.Subject)

'For all matches, move those matches to respective folder (create folder if it does not exist)
If colMatches.Count > 0 Then
    For Each myMatch In colMatches
        folderName = "Docket # " & myMatch.Value
        If FolderExists(objDestinationFolder, folderName) Then
            Set objProjectFolder = objDestinationFolder.Folders(folderName)
        Else
            Set objProjectFolder = objDestinationFolder.Folders.Add(folderName)
        End If
        Item.Move objProjectFolder
    Next
End If

Set objProjectFolder = Nothing

End Sub

Function FolderExists(parentFolder As MAPIFolder, folderName As String)

Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Global = False
objRegEx.Pattern = folderName

For Each F In parentFolder.Folders
    Set colMatches = objRegEx.Execute(F.Name)
    If colMatches.Count > 0 Then
        FolderExists = True
        folderName = colMatches(0).Value
        Exit Function
    End If
Next

FolderExists = False
End Function

Answer 1

我最近升级到Outlook 2016并遇到了同样的问题：默认收件箱不在我预期的位置。

当我安装Outlook 2016时，它创建了一个默认商店“outlook数据文件”。当我添加我的电子邮件帐户时，它为每个帐户创建了一个单独的商店。直到后来我才意识到默认的收件箱位于未使用的“Outlook数据文件”中。

为了您的兴趣，此宏将显示包含默认收件箱的商店的名称：

Sub DsplUsernameOfStoreForDefaultInbox()

  Dim NS As Outlook.NameSpace
  Dim DefaultInboxFldr As MAPIFolder

  Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
  Set DefaultInboxFldr = NS.GetDefaultFolder(olFolderInbox)

  Debug.Print DefaultInboxFldr.Parent.Name

End Sub

在您的代码中替换

 Set myInbox = myAccounts.Item(i).GetDefaultFolder(olFolderInbox)

通过

Set myInbox = Session.Folders("outlook data file").Folders("Inbox")

将“Outlook数据文件”替换为包含您要访问的收件箱的商店名称后

。

您可以使用此技术引用任何商店中任何深度的任何文件夹。例如：

Set FldrTgt = Session.Folders("zzzz").Folders("yyyy").Folders("xxxx").Folders("wwww")

加分

我不明白：

Set objDestinationFolder = myInbox.Parent.Folders("Inbox")

这从myBox开始，使用属性Parent转到商店然后属性文件夹再次转到“收件箱”。它与：

相同

Set objDestinationFolder = myInbox

非默认收件箱的Outlook收件箱到文件夹分拣宏

1 个答案: