在 vba 中使用循环发送电子邮件

Question

我有一张姓名表，其中包含每个人的电子邮件地址。对于列表中的每个人，我需要通过电子邮件向他们发送一个名为 PDFMailer 的 PDF 和一个标题为全大写姓氏的 PDF。

所以我的解决方案是遍历列表，并为列表中的每个人将电子邮件放在循环正文中，附加 PDF，然后发送并重复收件人表的预定部分。

Sub Emails()

Dim wb As Workbook
Dim wsMedRec As Worksheet

Set wb = ActiveWorkbook
Set wsMedRec = wb.Sheets("Medical Records")

Dim i As Integer
Dim j As Integer

'sets up what is needed to email
Dim OutApp As Object
Dim OutMail As Object

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


'length of the sheet with the medical record information
Dim n As Integer
n = wsMedRec.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row

Dim upp, lower As Integer
Dim startdoc As Integer

'lets the user decide how long to run the code in case whole sheet is not wanted or needed
lower = InputBox("Enter the starting row number for the email recipients list.")
upp = InputBox("Enter the ending row number for the email recipients list.")

'upper bound cannot exceed the length of the sheet
If upp > n Then

    MsgBox ("You have chosen an upper bound that exceeds the length of your recipients list. End code and try again.")

End If


Dim lastname As String
Dim emailaddr As String
Dim docname, HIPAAname As String


'sends the fax for each row of info
For i = lower To upp

    lastname = wsMedRec.Range("B" & i).Value
    emailaddr = wsMedRec.Range("I" & i).Value


    'puts together the names of the two documents that are going to be faxed
    docname = "PDFMailer.pdf"
    HIPAAname = UCase(lastname) & ".pdf"

    On Error Resume Next
    With OutMail
        .To = emailaddr
        .CC = ""
        .BCC = ""
        .Subject = ""
        .Body = ""
        .Attachments.Add ("S:\Med Records\Letters\" & docname)     

        .Attachments.Add ("S:\Med Records\HIPAAS\" & HIPAAname)
        .Send
    End With
    On Error GoTo 0

Next


'ends the email server use
Set OutMail = Nothing
Set OutApp = Nothing




End Sub

我运行代码，它发送的第一封电子邮件与所有附件都很好。该代码在循环的其余迭代中运行，但它根本不发送任何电子邮件。它只发送第一个。

Answer 1

查看 MSDN 中的 Automating Outlook from a Visual Basic Application 文章。

尝试使用以下代码：

Sub Emails()

Dim wb As Workbook
Dim wsMedRec As Worksheet

Set wb = ActiveWorkbook
Set wsMedRec = wb.Sheets("Medical Records")

Dim i As Integer
Dim j As Integer

'sets up what is needed to email
Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")

'length of the sheet with the medical record information
Dim n As Integer
n = wsMedRec.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row

Dim upp, lower As Integer
Dim startdoc As Integer

'lets the user decide how long to run the code in case whole sheet is not wanted or needed
lower = InputBox("Enter the starting row number for the email recipients list.")
upp = InputBox("Enter the ending row number for the email recipients list.")

'upper bound cannot exceed the length of the sheet
If upp > n Then

    MsgBox ("You have chosen an upper bound that exceeds the length of your recipients list. End code and try again.")

End If


Dim lastname As String
Dim emailaddr As String
Dim docname, HIPAAname As String


'sends the fax for each row of info
For i = lower To upp

    lastname = wsMedRec.Range("B" & i).Value
    emailaddr = wsMedRec.Range("I" & i).Value


    'puts together the names of the two documents that are going to be faxed
    docname = "PDFMailer.pdf"
    HIPAAname = UCase(lastname) & ".pdf"

    On Error Resume Next
    Set OutMail = OutApp.CreateItem(0)
    With OutMail      
        .To = emailaddr
        .CC = ""
        .BCC = ""
        .Subject = ""
        .Body = ""
        .Attachments.Add ("S:\Med Records\Letters\" & docname)    

        .Attachments.Add ("S:\Med Records\HIPAAS\" & HIPAAname)
        .Send
    End With
    On Error GoTo 0

Next


'ends the email server use
Set OutMail = Nothing
Set OutApp = Nothing

End Sub