Outlook VBA - Select 創建“新電子郵件”時的發件人帳戶

Question

我正在使用 Outlook 設置多個帳戶（POP 和 IMAP）。 在編寫新的 email 時，我顯然可以通過單擊“發件人”按鈕並選擇適當的帳戶來更改用於發送 email 的帳戶。 但是，我經常忘記這樣做，然后 email 會從默認帳戶發送。

我想做的是捕獲新 email 的創建，並顯示一個帶有單選按鈕的表單，列出所有帳戶，以便在起草 email 之前選擇正確的發件人帳戶。

我可以使用帳戶列表創建表單，該表單將返回所選帳戶。 我還可以使用 Inspectors_NewInspector 事件捕獲新 email 的創建，但在嘗試設置發件人帳戶時遇到問題。

我使用 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事件不是訪問郵件項 object 的正確位置。 該事件發生在新的Inspector object 創建之后，但在 Inspector window 出現之前。 因此，我建議等待Inspector.Activate事件，該事件在檢查員變為活動 window 時觸發，無論是由於用戶操作還是通過程序代碼。

您可能會發現在每篇檢查器文章中實現檢查器包裝器並跟蹤項目級事件很有幫助。

其次， MailItem.SendUsingAccount屬性允許設置一個帳戶object，該帳戶表示要發送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 事件，但屬性錯誤仍然是只讀的。

然后，我修改了代碼以保存 email，然后再嘗試寫入 SendUsingAccount 屬性並且可行，但是，我並不完全高興這是一個特別優雅的解決方案，因為它強制將 email 保存為草稿。 我無法理解的是 email 在保存之前處於什么“狀態”，以及是否有另一種解決方案可以在不進行保存的情況下更改 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