Outlook VBA - Select Sender Account when "New Email" is created

Question

I'm using Outlook set up with a number of accounts (both POP and IMAP). When writing a new email I can obviously change which account is used to send the email by clicking the "From" button and selecting the appropriate account. However, I often forget to do this and the email then gets sent from the default account.

What I would like to be able to do is to trap the creation of the new email and display a form with radio buttons listing all the accounts so that the correct sender account can be selected before the email is drafted.

I can create the form with the list of accounts and which will return the selected account. I can also trap the creation of a new email with the Inspectors_NewInspector event but I am having problems when trying the set the Sender account.

I have tried the following code (in ThisOutlookSession) using the SendUsingAccount property but the code flags up an error saying that the property is read-only. Any ideas would be much appreciated.

Option Explicit

Private WithEvents objInspectors As Outlook.Inspectors

Private Sub Application_Startup()

  Set objInspectors = Application.Inspectors
  
End Sub

Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)

    Dim oEmail As Outlook.MailItem
    
    If TypeName(Inspector.CurrentItem) = "MailItem" Then
        Set oEmail = Inspector.CurrentItem
        Set oEmail.SendUsingAccount = GetUserSelectedInput '<<<<gives error 440 - property is read-only
    End If
    
End Sub

Private Function GetUserSelectedInput() As Account

    Dim oNs As Outlook.NameSpace
    
    Set oNs = Application.GetNamespace("MAPI")
    
    'The following line is selecting an arbitrary account for testing purposes
    'this will be replaced with the code to call a userform
    'that will return the selected account
    Set GetUserSelectedInput = oNs.Accounts.Item(2)
    
End Function

Answer 1

OK, that was silly - I was sure that I was getting a read-only error when setting SendUsingAccount property. Thanks niton for pointing out it works without it. So now I have the complete solution and it's working as required. For those that are interested, the complete code is listed below. It requires a simple form ("SelectAccount") which has a frame ("frmeOptionButtons") and two buttons ("btnOk" & "btnCancel") below the frame. The frame and form will resize depending on the number of accounts. It relies on using the form.tag property to pass a default account address when the form is opened and the selected address when OK is clicked.

The code for ThisOutlookSession is:

Option Explicit

Private WithEvents objInspectors As Outlook.Inspectors
Private WithEvents objEmail As Outlook.MailItem

Public Sub test()
    Set objInspectors = Application.Inspectors
End Sub

Private Sub Application_Startup()
    Set objInspectors = Application.Inspectors
End Sub

Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)

    If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
        If Len(Inspector.CurrentItem.EntryID) = 0 Then
            Set objEmail = Inspector.CurrentItem
        End If
    End If
  
End Sub

Private Sub objEmail_Open(Cancel As Boolean)

    Dim objAcc As Outlook.Account

    With objEmail
        Set objAcc = GetUserSelectedInput(.SendUsingAccount.SmtpAddress)
        If objAcc Is Nothing Then
            Cancel = True
        Else
            .SendUsingAccount = objAcc
        End If
    End With

    Set objAcc = Nothing
    Set objEmail = Nothing
    
End Sub

Private Function GetUserSelectedInput(DefaultAccount As String) As Outlook.Account

    Dim objNs As Outlook.NameSpace
    Dim objAcc As Outlook.Account
    Dim SelectedAccount As String
 
    With SelectAccount
        .tag = LCase(DefaultAccount)
        .Show
        SelectedAccount = ""
        On Error Resume Next 'in case form is closed
        SelectedAccount = .tag
        On Error GoTo 0
    End With
    
    If SelectedAccount = "" Then Exit Function
    
    Set objNs = Application.GetNamespace("MAPI")
    
    For Each objAcc In objNs.Accounts
        If LCase(objAcc.SmtpAddress) = SelectedAccount Then
            Set GetUserSelectedInput = objAcc
            Exit For
        End If
    Next
    
    Set objAcc = Nothing
    Set objNs = Nothing

End Function

The code for the SelectAccount form is:

Option Explicit

Private Sub btnCancel_Click()
    Me.tag = ""
    Me.Hide
End Sub

Private Sub btnOk_Click()
    
    Dim optButton As MSForms.OptionButton

    Me.tag = ""

    For Each optButton In Me.frmeOptionButtons.Controls
        If optButton.value Then
            Me.tag = optButton.tag
            Exit For
        End If
    Next
    
    Me.Hide

End Sub

Private Sub UserForm_Activate()
    
    Dim optButton As MSForms.OptionButton
    Dim NoOfBtns As Integer
    Dim CaptionWidth As Long
    Dim AccList() As String
    Dim DefaulAccount As String
    Dim i As Integer
    
    DefaulAccount = LCase(Me.tag)
    
    AccList = GetAccountList
   
    NoOfBtns = UBound(AccList)
    
    Me.btnOk.top = Me.frmeOptionButtons.top + (NoOfBtns) * 18 + 4
    Me.btnCancel.top = Me.btnOk.top
    Me.Height = Me.btnOk.top + Me.btnOk.Height + 36
    
    With Me.frmeOptionButtons
        
        .Height = NoOfBtns * 18 + 2
            
        For Each optButton In .Controls
            .Controls.Remove (optButton.Name)
        Next
    
        CaptionWidth = .Width - 4
        
        For i = 1 To NoOfBtns
        
            Set optButton = .Controls.Add("Forms.OptionButton.1")
              
            With optButton
                .left = 0
                .top = 18 * (i - 1)
                .Height = 18
                .Width = CaptionWidth
                .tag = LCase(AccList(i))
                .Caption = AccList(i)
                .value = (.tag = DefaulAccount)
            End With

        Next

    End With
    
End Sub

Private Function GetAccountList() As Variant

    Dim objNs As Outlook.NameSpace
    Dim objAcc As Outlook.Account
    Dim strAcc() As String
    Dim i As Integer
    
    Set objNs = Application.GetNamespace("MAPI")
    
    i = 0
    For Each objAcc In objNs.Accounts
        i = i + 1
        ReDim Preserve strAcc(i)
        strAcc(i) = objAcc.SmtpAddress
    Next

    GetAccountList = strAcc
    
    Set objAcc = Nothing
    Set objNs = Nothing

End Function

Answer 2

I tried using the Inspector.Activate event and still had the same problem with the SendUsingAccount property being read only. I also tried using the MailIem.Open event and still the property errors as read only.

I then modified the code to Save the email before attempting to write to the SendUsingAccount property and that works, However, I'm not completely happy that it's a particularly elegant solution since it forces the email to be saved as a draft. What I can't understand is what "state" the email is in prior to the Save and whether there's another solution where the SendUsingAccount can be changed without doing the Save.

The code I'm currently using is shown below. Any comments would be welcomed.

Option Explicit

Private WithEvents objInspectors As Outlook.Inspectors
Private WithEvents objEmail As Outlook.MailItem

Public Sub test()
    Set objInspectors = Application.Inspectors
End Sub


Private Sub Application_Startup()

    Set objInspectors = Application.Inspectors
  
End Sub

Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)

    If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
        If Len(Inspector.CurrentItem.EntryID) = 0 Then
            Set objEmail = Inspector.CurrentItem
        End If
    End If
  
End Sub


Private Sub objEmail_Open(Cancel As Boolean)

    Dim objAcc As Outlook.Account

    With objEmail
        Set objAcc = GetUserSelectedInput()
        If objAcc Is Nothing Then
            Cancel = True
        Else
            .Save
            .SendUsingAccount = objAcc
        End If
    End With

    Set objAcc = Nothing
    Set objEmail = Nothing
    
End Sub

Private Function GetUserSelectedInput() As Outlook.Account

    Dim oNs As Outlook.NameSpace
    
    Set oNs = Application.GetNamespace("MAPI")
    
    'The following line is selecting an arbitrary account for testing purposes
    'this will be replaced with the code to call a userform
    'that will return the selected account
    Set GetUserSelectedInput = oNs.Accounts.Item(3)
    
End Function

Answer 3

First of all, the Inspectors.NewInspector event is not the right place for accessing the mail item object. The event occurs after the new Inspector object is created but before the inspector window appears. So, I'd suggest waiting for the Inspector.Activate event which is fired when an inspector becomes the active window, either as a result of user action or through program code.

You may find the Implement a wrapper for inspectors and track item-level events in each inspector article helpful.

Second, the MailItem.SendUsingAccount property allows to set an Account object that represents the account under which the MailItem is to be sent. For example, a VBA sample code shows how to set up the property:

Sub SendUsingAccount()  
 Dim oAccount As Outlook.account  
 For Each oAccount In Application.Session.Accounts  
   If oAccount.AccountType = olPop3 Then  
     Dim oMail As Outlook.MailItem  
     Set oMail = Application.CreateItem(olMailItem)  
     oMail.Subject = "Sent using POP3 Account"  
     oMail.Recipients.Add ("someone@example.com")  
     oMail.Recipients.ResolveAll  
     Set oMail.SendUsingAccount = oAccount  
     oMail.Send  
   End If  
 Next  
End Sub