Outlook 2003 VBA to detect selected account when sending

Question

Is it possible to detect which account an email is being sent via the Application_ItemSend VBA function of Outlook 2003? The accounts are POP3/SMTP on a standalone machine, and not MAPI or Exchange based.

I have tried using "Outlook Redemption" (http://www.dimastr.com/redemption/) but I just cannot find any property / method that will tell me which of the accounts the email is being sent through.

I don't need to be able to amend/select the account being sent from, just simply detect.

Answer 1

I have found a way of finding the account name, thanks to this link which provides the code for selecting a particular account.

Using this code as a base, I have create a simple GetAccountName function, which is doing exactly what I need it to do.

Edit: The below will only work if you're NOT using Word as the editor.

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

Here is a try:

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

This will give you the display name of the current sending account.
If that's not enough, you can try the other properties of the Item.sendUsingAccount var.

Answer 3

In Outlook 2003, you need to use the RDOMail object in Redemption to access the Account property of a mail item. Here is some code that changes the SendAccount from the default account to another account in the OL Profile, for all items in the Outbox. It could be improved by coding an account selection subroutine that reads the accounts in the OL Profile and presents them as a list for the user to select from. In the code provided the new send account is hard-coded.

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