Слушайте конкретную учетную запись Outlook с VB - PullRequest
Новая
       36

Слушайте конкретную учетную запись Outlook с VB

0 голосов
/ 18 мая 2018

Я хотел бы попросить вашей помощи здесь.Я пытаюсь закодировать скрипт (надстройка Outlook VSTO) для прослушивания всех входящих писем от определенной учетной записи Outlook.В моем приложении Outlook я настроил несколько учетных записей (учетных записей Exchange), но меня интересует только одна из них.У меня есть код ниже, который прослушивает папку «Входящие» из текущей учетной записи по умолчанию. 

Private Sub ThisAddIn_Startup() Handles Me.Startup

   Dim outlookNameSpace As Outlook.NameSpace
   outlookNameSpace = Me.Application.GetNamespace("MAPI")
   inbox = OutlookNameSpace.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
   Mailitem = inbox.Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object) Handles Mailitem.ItemAdd
   If TypeOf (item) Is Outlook.MailItem Then
       --Do some things here--
   End if

End Sub

Код работает отлично, но он прослушивает учетную запись по умолчанию.Я хочу изменить его, чтобы прослушать другую учетную запись, настроенную в Outlook.

У вас есть идеи?

Большое спасибо !!

Ответы [ 2 ]

0 голосов
/ 21 июня 2018

это может помочь !!!скопируйте этот код в сеансе Outlook. изображение сеанса Outlook 

Private Sub Application_Startup()
  Dim objNS As NameSpace
  Set objNS = Application.Session

  Set olInboxItems = GetFolderPath("your other email address name\Inbox").Items
  Set objNS = Nothing

  Set objInbox = Application.Session.GetDefaultFolder(olFolderInbox)
  Set objItems = objInbox.Items

  End Sub

  Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
  On Error Resume Next
  'your code what you want to do  with additional email address
  End Sub

  Private Sub objItems_ItemAdd(ByVal Item As Object)
  'your code for your default email address
  End Sub

  Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer

    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
    Set GetFolderPath = oFolder
    Exit Function

    GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function
0 голосов
/ 18 мая 2018

Вместо использования Namespace.GetDefaultFolder найдите нужное хранилище в коллекции Namespace.Stores и получите папку «Входящие» из этого хранилища, используя Store.GetDefaultFolder

...