Runtime error “-2147024809” Moving Sent Mails To SentMail-Folder of secondary account

问题

I have two accounts open in Outlook.

When I send a Mail via the secondary account it appears in the sent folder of the primary account.

I want to move the sent mail to the sent folder of the secondary account whenever I send mail.

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

I get this Error message:

-2147024809 - Unfortunately there is a problem. You can try again

It shows that the line Set newFolder = NS.GetSharedDefaultFolder(objOwner, olFolderSentMail) is causing this problem.

回答1:

The error is MAPI_E_INVALID_PARAMETER. Most likely that means the specified mailbox is not an Exchange mailbox or it belongs to a different Exchange org.

If that mailbox is already opened in the current profile, you can access that Store object (and use Store.GetDefaultFolder) from the Namespace.Stores collection.

回答2:

Dmitry Streblechenko's answer worked! Here is how I did it if anyone got the same problem:

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

来源：https://stackoverflow.com/questions/55103754/runtime-error-2147024809-moving-sent-mails-to-sentmail-folder-of-secondary-ac

标签

vba

outlook

runtime