创建 "New Email" 时的 Outlook VBA - Select 发件人帐户

Question

我正在使用设置了多个帐户（POP 和 IMAP）的 Outlook。当写一封新电子邮件时，我显然可以通过单击“发件人”按钮并选择适当的帐户来更改用于发送电子邮件的帐户。但是，我经常忘记这样做，然后从默认帐户发送电子邮件。

我想做的是捕获新电子邮件的创建并显示一个带有列出所有帐户的单选按钮的表单，以便在起草电子邮件之前可以选择正确的发件人帐户。

我可以创建包含帐户列表的表单，这将 return 选定的帐户。我还可以使用 Inspectors_NewInspector 事件捕获新电子邮件的创建，但我在尝试设置发件人帐户时遇到问题。

我已经使用 SendUsingAccount 属性尝试了以下代码（在 ThisOutlookSession 中），但代码标记了一个错误，指出属性是只读的。任何想法将不胜感激。

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

首先，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 事件在检查器变为活动状态时触发 window，无论是作为用户操作的结果还是通过程序代码。

您可能会发现 Implement a wrapper for inspectors and track item-level events in each inspector 文章有帮助。

其次，MailItem.SendUsingAccount property allows to set an Account 对象表示要发送 MailItem 的帐户。例如，VBA 示例代码显示了如何设置属性:

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

Answer 2

我尝试使用 Inspector.Activate 事件，但仍然遇到相同的问题，因为 SendUsingAccount 属性是只读的。我也尝试使用 MailIem.Open 事件，但属性错误仍然是只读的。

然后我修改了代码以在尝试写入 SendUsingAccount 属性之前保存电子邮件，这很有效，但是，我并不完全高兴这是一个特别优雅的解决方案，因为它强制将电子邮件发送到保存为草稿。我不明白的是电子邮件在保存之前处于什么“状态”，以及是否有另一种解决方案可以在不保存的情况下更改 SendUsingAccount。

我目前使用的代码如下所示。欢迎任何评论。

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

好吧，那太傻了——我确定我在设置 SendUsingAccount 属性时遇到了只读错误。感谢 niton 指出它没有它也能工作。所以现在我有了完整的解决方案，它可以按要求工作。对于那些感兴趣的人，下面列出了完整的代码。它需要一个简单的表单（“SelectAccount”），它有一个框架（“frmeOptionButtons”）和框架下方的两个按钮（“btnOk”和“btnCancel”）。框架和表格将根据帐户数量调整大小。它依赖于使用 form.tag 属性在打开表单时传递默认帐户地址，并在单击“确定”时传递所选地址。

ThisOutlookSession 的代码是：

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

SelectAccount 表单的代码是：

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

创建 "New Email" 时的 Outlook VBA - Select 发件人帐户

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

email

outlook

vba