Outlook 2003中VBA发送时，检测选择账户

Question

是否有可能发现哪个帐户正在通过Outlook 2003年实现Application_ItemSend VBA函数发送的电子邮件？该账户是POP3 / SMTP一个独立的机器上，而不是MAPI或基于Exchange。

我一直在使用“瞭望救赎”（http://www.dimastr.com/redemption/）尝试，但我无法找到任何属性/方法会告诉我该帐户的电子邮件被允许进入天堂。

我并不需要能够修改/选择帐户的发送，只是简单地检测。

Answer 1

我发现找到的帐户名，这要归功于this link它提供了一种选择特定帐户的代码的方式。

使用此代码作为基础，我创建一个简单的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

这里是一个尝试：

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

这会给你当前的发送帐户的显示名称。 如果这还不够，你可以尝试Item.sendUsingAccount VAR的其他属性。

Answer 3

在Outlook 2003中，您需要使用RDOMail对象赎回来访问邮件项目的帐户属性。下面是一些代码，从默认的帐户更改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