如何在向唯一人發送一組行的同時在 VBA 宏代碼中嵌入 CC 和 BCC

Question

我有一個宏，可以將一行或多行通過電子郵件發送給范圍內的每個人。 我只想知道如何在每封電子郵件中添加相同的 CC 和 BCC。我對 Excel VBA 很熟。 請幫忙。

這是代碼

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

應該

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

如果您想添加不止一封電子郵件，那么

.cc = "email address; email address"

Answer 2

我會建議使用單獨的子程序來發送電子郵件。 使用現有的子程序對數據進行分類，並在您想要發送電子郵件時調用以下子程序。 這將解決您添加和解析 bcc 和 cc 郵件地址的問題，此外，還將對 Outlook 實例進行出色的內存管理。

請使用以下代碼：

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

請構造以分號 (;) 分隔的電子郵件地址字符串。