如何将一封电子邮件发送到 Excel 工作簿中的电子邮件列表？ excel VBA

Question

This is my current code, but I want to be able to send to a list of emails that is in my workbook. How would I go about that with what I have for the mailing section of my code. I want to have column R named mailing list and it will send to whatever emails are inserted into that column/list all together. Think when I try stuff, I'm missing a component somehow.

Sub SendReminderMail1()

  Dim wb1 As Workbook
  Dim wb2 As Workbook
  Dim TempFilePath As String
  Dim TempFileName As String
  Dim FileExtStr As String
  Dim OutApp As Object
  Dim OutMail As Object



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

Set wb1 = ActiveWorkbook


TempFilePath = Environ$("temp") & "\"
TempFileName = "Copy of " & wb1.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
FileExtStr = "." & LCase(Right(wb1.Name, Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))

wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)

wb2.Worksheets(1).Range("A1").Value = "Copy created on " & Format(Date, "dd-mmm-yyyy")

wb2.Save


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
    .To = " "
    .CC = ""
    .BCC = ""
    .Subject = "Rotations needed for ."
    .Body = "Hey there,  equipment needs to be rotated."
    .Attachments.Add wb2.FullName

    .Display   'or use .Send to send with display proof reading

End With
On Error GoTo 0
wb2.Close savechanges:=False

Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

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


MsgBox "Your Automated Email for BP Rotations was successfully ran at " & TimeValue(Now), vbInformation

End Sub

Answer 1

In your code I've you set the recipients fields to empty strings:

With OutMail
    .To = " "
    .CC = ""
    .BCC = ""

Instead, you need to read values from the column R and add recipients for the email. To add recipients I'd recommend using the Recipients collection which can be retrieved using the corresponding property of the MailItem class.

Dim recipients As Outlook.Recipients = Nothing

Set recipients = mail.Recipients

' now we add new recipietns to the e-mail
        recipientTo = recipients.Add("Eugene")
        recipientTo.Type = Outlook.OlMailRecipientType.olTo
        recipientCC = recipients.Add("Dmitry")
        recipientCC.Type = Outlook.OlMailRecipientType.olCC
        recipientBCC = recipients.Add("eugene.astafiev@somedomain.com")
        recipientBCC.Type = Outlook.OlMailRecipientType.olBCC
        recipients.ResolveAll()

Read more about that in the How To: Fill TO,CC and BCC fields in Outlook programmatically article.

Answer 2

Mail Merge not your cup of tea huh...

Maybe what you need is a Do while Loop where it references a cell in a Table of people, then moves down each step till the E-mail is blank just chugging through Row after Row of E-mails driving that sweet CPU usage up.

Like a user programmed Mail Merge but in Excel and not in a Word Processor... Like Mail Merge... In Word, but not in Word, In Excel In VBA...