Outlook 2003 VBA для обнаружения выбранной учетной записи при отправке

Question

Можно ли определить, с какой учетной записи отправляется электронная почта, с помощью функции Application_ItemSend VBA в Outlook 2003?Учетными записями являются POP3 / SMTP на автономной машине и , а не MAPI или Exchange.

Я пытался использовать "Погашение Outlook" (http://www.dimastr.com/redemption/), но просто не могу найти какое-либо свойство /метод, который скажет мне, через какие учетные записи отправляется электронное письмо.

Мне не нужно вносить изменения или выбирать учетную запись, с которой отправляется письмо, просто обнаружите.

Answer 1

Я нашел способ найти имя учетной записи, благодаря этой ссылке , которая предоставляет код для выбора конкретной учетной записи.

Используя этот код в качестве основы, я создал простую функцию GetAccountName, которая делает именно то, что мне нужно.

Редактировать: Нижеследующее будет работать, только если вы НЕ используете Word в качестве редактора.

Private Function GetAccountName(ByVal Item As Outlook.MailItem) As String
    Dim OLI As Outlook.Inspector
    Const ID_ACCOUNTS = 31224

    Dim CBP As Office.CommandBarPopup

    Set OLI = Item.GetInspector
    If Not OLI Is Nothing Then
        Set CBP = OLI.CommandBars.FindControl(, ID_ACCOUNTS)
        If Not CBP Is Nothing Then
            If CBP.Controls.Count > 0 Then
                GetAccountName = CBP.Controls(1).Caption
                GoTo Exit_Function
            End If
        End If
    End If
    GetAccountName = ""

Exit_Function:
    Set CBP = Nothing
    Set OLI = Nothing
End Function

Answer 2

В Outlook 2003 вам необходимо использовать объект RDOMail в Redemption для доступа к свойству Account почтового элемента.Вот некоторый код, который изменяет SendAccount из учетной записи по умолчанию на другую учетную запись в профиле OL для всех элементов в папке «Исходящие».Это может быть улучшено путем кодирования подпрограммы выбора учетной записи, которая считывает учетные записи в профиле OL и представляет их в виде списка для выбора пользователем.В предоставленном коде новая учетная запись отправки жестко запрограммирована.

Sub ChangeSendAccountForAllItems()
    On Error Resume Next
    Dim oOutlook As Application
    Dim olNS As Outlook.NameSpace
    Dim sOrigSendAccount As String
    Dim sNewSendAccount As String
    Dim iNumItemsInFolder As Integer
    Dim iNumItemsChanged As Integer
    Dim i As Integer

    Dim rRDOSession As Redemption.RDOSession
    Dim rRDOFolderOutbox As Redemption.RDOFolder
    Dim rRDOMail As Redemption.RDOMail

    'Create instance of Outlook
    Set oOutlook = CreateObject("Outlook.Application") 
    Set olNS = Application.GetNamespace("MAPI")

    'Create instance of Redemption
    Set rRDOSession = CreateObject("Redemption.RDOSession") 
    rRDOSession.Logon

    'Set a new Send Account (using Redemption)
    'Change this to any SendAccount in your Profile
    sNewSendAccount = "ThePreferredSendAccountNameInTheProfile"       
    Set rRDOAccount = rRDOSession.Accounts(sNewSendAccount)

    Response = MsgBox("New Send Account is: " & sNewSendAccount & vbCrLf & _
        vbCrLf, _
        vbOK + vbInformation, "Change SendAccount for All Items")

    'Get items in Outbox folder (value=4) (using Redemption)
    Set rRDOFolderOutbox = rRDOSession.GetDefaultFolder(olFolderOutbox)
    Set rRDOMailItems = rRDOFolderOutbox.Items
    iNumItemsInFolder = rRDOFolderOutbox.Items.Count
    iNumItemsChanged = 0

    'For all items in the folder, loop through changing Send Account (using Redemption)
     For i = 1 To iNumItemsInFolder
        Set rRDOItem = rRDOMailItems.Item(i)
        rRDOItem.Account = rRDOAccount
        rRDOItem.Save
        iNumItemsChanged = iNumItemsChanged + 1

        '3 lines below for debugging only
        'Response = MsgBox("Item " & iNumItemsChanged & " of " & iNumItemsInFolder & " Subject: " & vbCrLf & _
        '            rRDOItem.Subject & vbCrLf, _
        '            vbOK + vbInformation, "Change SendAccount for All Items")

    Next

    Response = MsgBox(iNumItemsChanged & " of " & iNumItemsInFolder & " items " & _
        "had the SendAccount changed to " & sNewSendAccount, _
        vbOK + vbInformation, "Change SendAccount for All Items")

    Set olNS = Nothing
    Set rRDOFolderOutbox = Nothing
    Set rRDOMailItems = Nothing
    Set rRDOItem = Nothing
    Set rRDOAccount = Nothing
    Set rRDOSession = Nothing

End Sub

Answer 3

Вот попытка:

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
   Msgbox(Item.SendUsingAccount.DisplayName)
End Sub

Это даст вам отображаемое имя текущей отправляющей учетной записи.
Если этого недостаточно, вы можете попробовать другие свойства Item.sendUsingAccount var.