Outlook 2003 VBA 在发送时检测所选帐户

Question

是否可以通过 Outlook 2003 的 Application_ItemSend VBA 函数检测电子邮件正在发送给哪个帐户？这些帐户是独立计算机上的 POP3/SMTP，而不是基于 MAPI 或 Exchange。

我尝试过使用“Outlook Redemption”（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

这是一个尝试：

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

这将为您提供当前发送帐户的显示名称。
如果这还不够，您可以尝试 Item.sendUsingAccount 变量的其他属性。

Answer 3

在 Outlook 2003 中，您需要使用 Redemption 中的 RDOMail 对象来访问邮件项目的 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