Outlook 2010 - VBA - установить скрытую копию в ItemSend
Программа: Outlook 2010
ОС: Win8
VBA Skill: Новичок
Заметки:
Это прекрасно работает, если я уберу следующую опцию
Private Sub Application Item_Send
'[3]
If Item.SendUsingAccount = "Account Name here" Then
Если я не удаляю его (сохраняя свое исключение BCC), электронная почта при запуске Private Sub Application _Startup работает, однако это BCCs только адрес электронной почты, указанный в элементе [3] = "special@domain.com".
Когда часть [3] удаляется и запускается как закодировано.
1) 1 электронное письмо при запуске, BCCing всех учетных записей, перечисленных для проверки макроса,
2) В течение дня все отправленные электронные письма имеют правильный BCC, все исключения работают как закодированные.
Кажется, что я что-то упустил, что мешает каждому почтовому коду запускаться при запуске почтового кода.
Я перепробовал ряд изменений, в том числе добавил IF & else функции.
Оба запускаются в моей сессии Outlook
Код:
Private Sub Application_Startup()
'Creates a new e-mail item and modifies its properties on startup
'Testing email settings, checking Macros enabled
Dim olApp As Outlook.Application
Dim objMail As Outlook.mailItem
Set olApp = Outlook.Application
'Create e-mail item
Set objMail = olApp.CreateItem(olMailItem)
With objMail
.Subject = "Login Test" & " | " & Format(Now, "YYYYMMDD - HH:mm:ss")
.Body = "Testing the BCC" & " | " & Format(Now, "YYYYMMDD")
.To = "1.alerts@domain.com; device@domain.com"
.Recipients.ResolveAll
.Send
End With
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'source: http://www.outlookcode.com/article.aspx?id=72
'source: http://www.outlookforums.com/threads/89987-auto-bcc-vba-macro-how-add-exceptions/ (exceptions) [2]
'source: http://www.groovypost.com/howto/microsoft/how-to-automatically-bcc-in-outlook-2010/#comment-312919 (sendusing) [3]
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim strBcc As String
'On Error Resume Next
'[2]
If Item.Categories = "zBCC no" Then
Exit Sub
Else
If Item.To = "personal@domain.com" Then
Exit Sub
Else
If InStr(1, Item.Body, "zebra") Then
Exit Sub
Else
If Item.To = "1@domain.com" Or Item.To = "2@domain.com" Then
strBcc = "3@domain.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
Exit Sub
Else
'[3]
If Item.SendUsingAccount = "Account Name here" Then
strBcc = "special@domain.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
Exit Sub
Else
' #### USER OPTIONS ####
' address for Bcc -- must be SMTP address or resolvable to a name in the address book
strBcc = "1@domain.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
strBcc = "2@domain.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
strBcc = "3@domain.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
End If
End If
End If
End If
End If
Set objRecip = Nothing
End Sub
1 ответ
Возможно, у меня ложное впечатление, что в то время, когда вы писали это, вы не знали, как отлаживать. Это может быть полезно http://www.cpearson.com/Excel/DebuggingVBA.aspx
Вот упрощенная непроверенная версия. Я удалил все остальные заявления.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'source: http://www.outlookcode.com/article.aspx?id=72
'source: http://www.outlookforums.com/threads/89987-auto-bcc-vba-macro-how-add-exceptions/ (exceptions) [2]
'source: http://www.groovypost.com/howto/microsoft/how-to-automatically-bcc-in-outlook-2010/#comment-312919 (sendusing) [3]
Dim objRecip As Recipient
Dim strMsg As String
Dim res As Integer
Dim strBcc As String
'[2]
If Item.Categories = "zBCC no" Then Exit Sub
If Item.To = "personal@domain.com" Then Exit Sub
If InStr(1, Item.Body, "zebra") Then Exit Sub
If Item.To = "1@domain.com" Or Item.To = "2@domain.com" Then
strBcc = "3@domain.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
GoTo ExitRoutine
End If
'[3]
If Item.SendUsingAccount = "Account Name here" Then
strBcc = "special@domain.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
GoTo ExitRoutine
End If
' #### USER OPTIONS ####
' address for Bcc -- must be SMTP address or resolvable to a name in the address book
strBcc = "1@domain.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
GoTo ExitRoutine
End If
End If
strBcc = "2@domain.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
GoTo ExitRoutine
End If
End If
strBcc = "3@domain.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
ExitRoutine:
Set objRecip = Nothing
End Sub
При отладке вы заметите Item.SendUsingAccount всегда пустым.
Вы можете попробовать настроить SendUsingAccount. Использовать почтовую учетную запись, которую вы хотите, в своем почтовом макросе, но она немного сложнее, чем SentOnBehalfOfName (From). Обратите внимание, что установка вручную From не будет обновлять SentOnBehalfOfName.
Вы можете увидеть, как это работает с этим.
Sub SetSentOnBehalf()
Dim objMsg As MailItem
Set objMsg = Application.CreateItem(0)
objMsg.SentOnBehalfOfName = "bingo@bongo.com"
objMsg.Display
MsgBox " SentOnBehalfOfName in the From: " & objMsg.SentOnBehalfOfName
Set objMsg = Nothing
End Sub