[英]Outlook VBA - Select Sender Account when "New Email" is created
I'm using Outlook set up with a number of accounts (both POP and IMAP).我正在使用 Outlook 设置多个帐户(POP 和 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.
在编写新的 email 时,我显然可以通过单击“发件人”按钮并选择适当的帐户来更改用于发送 email 的帐户。 However, I often forget to do this and the email then gets sent from the default account.
但是,我经常忘记这样做,然后 email 会从默认帐户发送。
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.我想做的是捕获新 email 的创建,并显示一个带有单选按钮的表单,列出所有帐户,以便在起草 email 之前选择正确的发件人帐户。
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.
我还可以使用 Inspectors_NewInspector 事件捕获新 email 的创建,但在尝试设置发件人帐户时遇到问题。
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.我使用 SendUsingAccount 属性尝试了以下代码(在 ThisOutlookSession 中),但代码标记了一个错误,指出该属性是只读的。 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
First of all, the Inspectors.NewInspector event is not the right place for accessing the mail item object.首先, Inspectors.NewInspector事件不是访问邮件项 object 的正确位置。 The event occurs after the new
Inspector
object is created but before the inspector window appears.该事件发生在新的
Inspector
object 创建之后,但在 Inspector window 出现之前。 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.因此,我建议等待Inspector.Activate事件,该事件在检查员变为活动 window 时触发,无论是由于用户操作还是通过程序代码。
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 anAccount object that represents the account under which the MailItem
is to be sent.其次, MailItem.SendUsingAccount属性允许设置一个帐户object,该帐户表示要发送
MailItem
的帐户。 For example, a VBA sample code shows how to set up the property:例如,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
I tried using the Inspector.Activate event and still had the same problem with the SendUsingAccount property being read only.我尝试使用 Inspector.Activate 事件,但 SendUsingAccount 属性为只读时仍然存在同样的问题。 I also tried using the MailIem.Open event and still the property errors as read only.
我还尝试使用 MailIem.Open 事件,但属性错误仍然是只读的。
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.然后,我修改了代码以保存 email,然后再尝试写入 SendUsingAccount 属性并且可行,但是,我并不完全高兴这是一个特别优雅的解决方案,因为它强制将 email 保存为草稿。 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.
我无法理解的是 email 在保存之前处于什么“状态”,以及是否有另一种解决方案可以在不进行保存的情况下更改 SendUsingAccount。
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
OK, that was silly - I was sure that I was getting a read-only error when setting SendUsingAccount property.好的,这很愚蠢 - 我确定在设置 SendUsingAccount 属性时遇到了只读错误。 Thanks niton for pointing out it works without it.
感谢 niton 指出没有它也可以工作。 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.
它需要一个简单的表单(“SelectAccount”),它有一个框架(“frmeOptionButtons”)和框架下方的两个按钮(“btnOk”和“btnCancel”)。 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.
它依赖于使用 form.tag 属性在打开表单时传递默认帐户地址,并在单击确定时传递所选地址。
The code for ThisOutlookSession is: 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
The code for the SelectAccount form is: 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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.