Ошибка выполнения Outlook VBA "-2147024809" Перемещение писем в папку SentMail - PullRequest
Новая
       25

Ошибка выполнения Outlook VBA "-2147024809" Перемещение писем в папку SentMail

1 голос
/ 11 марта 2019

У меня две открытые учетные записи в 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 - К сожалению, есть проблема. Вы можете попробовать еще раз

Это показывает, что строка "Set newFolder = NS.GetSharedDefaultFolder (objOwner, olFolderSentMail)" вызывает эту проблему.

Что я должен изменить, чтобы предотвратить эту ошибку?

Ответы [ 2 ]

2 голосов
/ 11 марта 2019

Ошибка MAPI_E_INVALID_PARAMETER. Скорее всего, это означает, что указанный почтовый ящик не является почтовым ящиком Exchange или принадлежит другой организации Exchange.

Если этот почтовый ящик уже открыт в текущем профиле, вы можете получить доступ к этому объекту Store (и использовать Store.GetDefaultFolder) из коллекции Namespace.Stores.

0 голосов
/ 15 марта 2019

Ответ Дмитрия Стребленченко сработал! Вот как я это сделал, если у кого-то возникла такая же проблема: 

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
...