Question

我在Outlook中打开了两个帐户。当我通过辅助帐户发送邮件时，由于某种原因，它没有出现在其发送文件夹中，而是出现在主要帐户的已发送文件夹中。因此，我想创建一个宏，每当我要发送邮件时，该宏就会将已发送的邮件移动到辅助帐户的已发送文件夹中。到目前为止，我有这个：

Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace

Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderSentMail).Items
End Sub

Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Folder As Outlook.Folder

If TypeName(Item) = "MailItem" Then
     If Item.SenderName = "MY SECONDARY EMAIL" Then
         Dim NS As Outlook.NameSpace
         Dim objOwner As Outlook.Recipient
         Dim newFolder As Outlook.Folder

         Set NS = Application.GetNamespace("MAPI")
         Set objOwner = NS.CreateRecipient("mysecondary@email.de")
         objOwner.Resolve

         If objOwner.Resolved Then
             Set newFolder = NS.GetSharedDefaultFolder(objOwner, olFolderSentMail)
             MsgBox (newFolder)
             Item.Move newFolder
         End If
     End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub

但是我总是得到这个奇怪的错误消息：

-2147024809-不幸的是，这是一个问题。您可以重试

它表明“设置newFolder = NS.GetSharedDefaultFolder（objOwner，olFolderSentMail）”行引起了此问题。

为了防止此错误，我必须更改什么？

Answer 1

德米特里·斯特雷布琴科的答案奏效了！如果有人遇到相同的问题，这是我的方法：

Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
    Dim outlookApp As Outlook.Application
    Dim objectNS As Outlook.NameSpace

    Set outlookApp = Outlook.Application
    Set objectNS = outlookApp.GetNamespace("MAPI")
    Set inboxItems = objectNS.GetDefaultFolder(olFolderSentMail).Items
End Sub

Sub inboxItems_ItemAdd(ByVal Item As Object)
    If TypeName(Item) = "MailItem" Then
         If Item.SenderName = "SENDERNAME" Then
             Dim NS As Outlook.NameSpace
             Dim objOwner As Outlook.Recipient
             Dim newFolder As Outlook.Folder
             Dim colStores As Outlook.Stores
             Dim oStore As Outlook.Store
             Dim oRoot As Outlook.Folder

             Set NS = Application.GetNamespace("MAPI")
             Set objOwner = NS.CreateRecipient("secondary@email.de")
             Set colStores = Application.Session.Stores

             For Each oStore In colStores
                Set oRoot = oStore.GetRootFolder
                If oStore = "SECONDARY EMAIL NAME" Then
                    Call EnumerateFolders(oRoot, Item)
                End If
             Next
         End If
    End If
End Sub

Sub EnumerateFolders(ByVal oFolder As Outlook.Folder, Item)
    Dim folders As Outlook.folders
    Dim Folder As Outlook.Folder
    Dim foldercount As Integer

    Set folders = oFolder.folders
    foldercount = folders.Count

    For Each Folder In folders
        If Folder.FolderPath = "\\SECONDARY EMAIL NAME\Sent Items" Then
            Item.Move Folder
        End If
    Next
End Sub

Outlook VBA运行时错误“ -2147024809”将邮件移动到SentMail文件夹

1 个答案: