[英]Using VBA create a rule to add a BCC address on outgoing Outlook email, depending on the account used
在Stackoverflow上找到了一个原始脚本,该脚本处理在Outlook中使用VBA脚本有条件地阻止Outlook根据发件人和收件人地址发送电子邮件的情况。
我发现还有另一个VBA脚本,当用户单击Outlook中的“发送”按钮时,该脚本会自动向所有外发电子邮件添加密件抄送地址,而无需用户干预。
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim strBcc As String
On Error Resume Next
strBcc = "HR@company.com"
Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
If Not objRecip.Resolve Then
strMsg = "Could not resolve the Bcc recipient. " & _
"Do you want still to send the message?"
res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve Bcc Recipient")
If res = vbNo Then
Cancel = True
End If
End If
Set objRecip = Nothing
End Sub
我想做的就是修改此脚本,以便它可以根据用户用来发送电子邮件的WHICH电子邮件帐户更改添加的密件抄送地址。
例如:
If oMail.AccountThatImSendingFrom = "myself@privateemail.com" Then
strBcc = "myaccount@gmail.com"
ElseIf oMail.AccountThatImSendingFrom = "myself@company.com" Then
strBcc = "HM@company.com"
EndIf
Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
If Not objRecip.Resolve Then
strMsg = "Could not resolve the Bcc recipient. " & _
"Do you want still to send the message?"
res = MsgBox(strMsg, vbYesNo + vbDefaultButton1, _
"Could Not Resolve Bcc Recipient")
If res = vbNo Then
Cancel = True
End If
End If
Set objRecip = Nothing
我尝试了广泛的搜索,但是似乎找不到可以调整的好例子。
还有另外一个代码示例在这里 ,我只是不能设法正确读取-可能是因为所有的嵌入IF语句的。
谁能帮助我或为我指明正确的方向?
安德鲁
我自己找到了答案。 我的代码如下:
Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objRecip As Recipient
Dim strMsg As String
Dim strSendUsingAccount As String
Dim res As Integer
Dim strBcc As String
On Error Resume Next
'Figure out which email account you are using to send email
strSendUsingAccount = Item.SendUsingAccount
'Throw an error if you are using your internal email account
If strSendUsingAccount = "UserName@Internal.Dom" Then
strMsg = "You are trying to send an email using your internal Scanner Email account, which you can't do..." & vbCr & vbCr & "Please select a DIFFERENT email account to send the email from."
res = MsgBox(strMsg, vbOKOnly + vbExclamation, "Sending Mail Error")
Cancel = True
Exit Sub
End If
'If sending using your first account
If strSendUsingAccount = "user@privateemail.com" Then
strBcc = ""
End If
'If sending using your second account
If strSendUsingAccount = "user@workemail.com" Then
strBcc = "HR@workemail.com"
End If
'Choose whether CC/BCC recipient
Set objRecip = Item.Recipients.Add(strBcc)
objRecip.Type = olBCC
'Resolve it?
objRecip.Resolve
'Clear the recipient
Set objRecip = Nothing
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.