如何在向唯一人发送一组行的同时在 VBA 宏代码中嵌入 CC 和 BCC

Question

I have got a macro which would eMail a row or rows to each person in a range. I just want to know how to add CC and BCC which are same in every email.I am amature to Excel VBA. Please help.

here is the code

Sub Send_Row_Or_Rows_1()

Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim StrBody As String

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With


Set Ash = ActiveSheet

'Set filter range and filter column (Column with names)
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
FieldNum = 1    'Filter column = A because the filter range start in A

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=Cws.Range("A1"), _
        CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
    For Rnum = 2 To Rcount

        'Filter the FilterRange on the FieldNum column
        FilterRange.AutoFilter Field:=FieldNum, _
                               Criteria1:=Cws.Cells(Rnum, 1).Value

        'Look for the mail address in the MailInfo worksheet
        mailAddress = ""
        On Error Resume Next
        mailAddress = Application.WorksheetFunction. _
                      VLookup(Cws.Cells(Rnum, 1).Value, _
                            Worksheets("Mailinfo").Range("A1:B" & _
                            Worksheets("Mailinfo").Rows.Count), 2, False)
        On Error GoTo 0

        If mailAddress <> "" Then
            With Ash.AutoFilter.Range
                On Error Resume Next
                Set rng = .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With

            Set OutMail = OutApp.CreateItem(0)

            On Error Resume Next

            With OutMail
                .to = mailAddress
                .Subject = "Test mail"
                .HTMLBody = StrBody & RangetoHTML(rng)
                .Display  'Or use Send

                StrBody = Sheets("Sheet2").Range("A1").Value & "<br>" & "<br>" & _
          Sheets("Sheet2").Range("A2").Value & "<br>" & "<br>" & _
          Sheets("Sheet2").Range("A3").Value & "<br><br><br>"

            End With
            On Error GoTo 0

            Set OutMail = Nothing
        End If

        'Close AutoFilter
        Ash.AutoFilterMode = False

    Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Answer 1

Should be

         With OutMail
                .to = mailAddress
                .cc = "email address"
                .Bcc ="email address"

If you want to add more than one email then

.cc = "email address; email address"

Answer 2

I will advise using a separate sub-routine for sending the email. Use the existing sub-routine to classify the data and call the below sub-routine whenever you want to send the email. This will resolve your problem of adding and resolving the bcc and cc mail addresses and in addition, will do excellent memory management with the outlook instance.

Please use the below code:

Sub SendEmail(ByVal str_To_EmailAddress As String, ByVal strSubject As String, ByVal strHTMLBody As String)
Dim OutApp As Object
Dim oMsg As Object
Dim objRecip As Object

Dim str_CC_EmailAddress As String
Dim str_BCC_EmailAddress As String

Set OutApp = CreateObject("Outlook.Application")
Set oMsg = OutApp.ActiveInspector.CurrentItem

str_CC_EmailAddress = "ABC@example.com"
str_BCC_EmailAddress = "XYZ@example.com"

With oMsg
    'Add to Email Address
    Set objRecip = oMsg.Recipients.Add(strToEmailAddress)
    objRecip.Type = olTo
    objRecip.Resolve

    'Add CC Email Address
    Set objRecip = oMsg.Recipients.Add(str_CC_EmailAddress)
    objRecip.Type = olCC
    objRecip.Resolve

    'Add BCC Email Address
    Set objRecip = oMsg.Recipients.Add(str_BCC_EmailAddress)
    objRecip.Type = olBCC
    objRecip.Resolve

    'Add Subject
    .Subject = strSubject

    'Add Body
    .BodyFormat = olFormatHTML

    'Display or Send
    .Display '.Send
End With

Set oMsg = Nothing

End Sub

Please construct the strings of email addresses separated by semicolons (;).