Автоматическая скрытая копия для почты отправителя

Я хочу написать код в VBA Outlook 2016, чтобы отправлять BCC в каждом письме, которое я отправляю, у меня много писем отправителей, много писем в одной учетной записи Outlook.

поэтому каждый раз, когда я отправляю электронное письмо с [email protected], автоматически отправляется электронное письмо BCC с [email protected], то же самое, если я отправляю с [email protected], отправлю BCC на [email protected]

я попробовал этот код, но он не работает, и в моем макросе безопасности все включено

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
Dim myOlApp As Outlook.Application
Dim myOlMsg As Outlook.MailItem

On Error Resume Next

Set myOlApp = CreateObject("Outlook.Application")
Set myMsg = myOlApp.ActiveInspector.CurrentItem

strBcc = myMsg.SenderEmailAddress

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

outlook vba outlook-2016
person Lama kh    schedule 14.01.2016    source источник
comment
On Error Resume Next скрывает ошибки. Удалите его, и вы можете отлаживать.   -  person niton    schedule 14.01.2016

Ответы (3)


arrow_upward
0
arrow_downward

Немного запутался в вашем вопросе. Если предположить, что у вас настроено несколько учетных записей в Outlook, это должно дать вам CurrenUser. свойство для получения имени текущего пользователя, вошедшего в систему.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim olNamespace As Outlook.NameSpace
    Dim olRec As Outlook.Recipient
    Dim Address$

    Set olNamespace = Application.GetNamespace("MAPI")

    Address = olNamespace.CurrentUser

    Set olRec = Item.Recipients.Add(Address)
    olRec.Type = olBCC
    olRec.Resolve
End Sub
person 0m3r    schedule 14.01.2016

arrow_upward
0
arrow_downward

Попробуйте SendUsingAccount

См. https://msdn.microsoft.com/en-us/library/office/ff869311.aspx

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objRecip As Recipient
Dim strMsg As String
Dim res As vbMsgBoxResult
Dim strBcc As String

'Dim myOlApp As Outlook.Application
'Dim myOlMsg As Outlook.MailItem

' hides errors, this is not a good thing
'On Error Resume Next 

' You can use the already running instance of Outlook
'Set myOlApp = CreateObject("Outlook.Application")

' CurrentItem is Item: ByVal Item As Object
'Set myMsg = myOlApp.ActiveInspector.CurrentItem

'strBcc = myMsg.SenderEmailAddress
strBcc = Item.SendUsingAccount

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
person niton    schedule 14.01.2016

arrow_upward
0
arrow_downward

Отправляемый элемент передается вашему коду в качестве параметра, не используйте myOlApp.ActiveInspector.CurrentItem. Инспектор мог быть уже закрыт или сообщение могло быть создано как встроенный ответ.

person Dmitry Streblechenko    schedule 14.01.2016