循环输入电子邮件地址并附加适用的 pdf

Question

这段代码应该是：

1. 将数组中列出的四个工作表（暗淡为 s）导出为 pdf
2. 将该 pdf 附加到电子邮件并添加简单的通用消息
3. 将适用的电子邮件地址插入电子邮件的“收件人”字段中
4. 显示电子邮件以允许用户在点击发送之前查看。

除了第 3 步之外，它都有效。

问题在于循环四个电子邮件地址以将它们加载到电子邮件的“收件人：字段”中。它将把第一个电子邮件地址分配给“strNames”，但会使用它，直到导出所有四张工作表，因此它们全部发送至 [电子邮件受保护]
只有退出该循环后，才会循环到下一个电子邮件地址[电子邮件受保护]
因为有四个电子邮件地址和四个工作表，所以我最终收到了 16 封电子邮件，而实际上应该是四封不同的电子邮件，每封电子邮件都有四个不同的适用附件。

完成后，我的桌面上应该有四封电子邮件可供发送，如下所示：
一封发送至“[email protected]”的电子邮件，并附有文件：2022 02 (TED)_ABC Therapy.pdf
一封发送至“[email protected]”的电子邮件，并附有文件：2022 02 (TED)_Achievement Therapy.pdf
一封发送至“[email protected]”的电子邮件，并附有文件：2022 02 (TED)_Barb Therapy.pdf
一封发送至“[email protected]”的电子邮件，并附有文件：2022 02 (TED)_Felisa, Robin V..pdf

Sub PDF_to_Email_2022_03_07()

    'ActiveWorkbook.Worksheets("ABC Therapy).Select         Email for ABC Therapy is
    `"[email protected]"`
    'ActiveWorkbook.Worksheets("Achieve Therapy").Select    Email for Achieve Therapy is
    `"[email protected]"`
    'ActiveWorkbook.Worksheets("Barb Therapy").Select       Email for Barb Therapy is
    `"[email protected]"`
    'ActiveWorkbook.Worksheets("Felisa, Robin V.").Select   Email for Felisa, Robin V. is
    `"[email protected]"`    

    Dim sh As Variant
    Dim strNames(1 To 4) As String

    strNames(1) = "[email protected]"
    strNames(2) = "[email protected]"
    strNames(3) = "[email protected]"
    strNames(4) = "[email protected]"

    Dim i As Long

    For i = 1 To 4

        For Each sh In Array _
            ("ABC Therapy", "Achieve Therapy", "Barb Therapy", "Felisa, Robin V.")
    
            Sheets(sh).Select

            Dim Wb As Workbook
            Dim FileName As String
            Dim OutlookApp As Object
            Dim OutlookMail As Object
            On Error Resume Next

            Set Wb = Application.ActiveWorkbook
            FileName = Wb.FullName

            xIndex = VBA.InStrRev(FileName, ".")

            If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 24)

            FileName = FileName & "_" + ActiveSheet.Name & ".pdf"

            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
            Set OutlookApp = CreateObject("Outlook.Application")
            Set OutlookMail = OutlookApp.CreateItem(0)
            With OutlookMail
            
                .To = strNames(i)
        
                .CC = ""
                .BCC = ""
                .Subject = "EI Payment Report"
                .Body = "Enclosed is your monthly Report."
                .Attachments.Add FileName
                .Display

            End With
            Kill FileName
            Set OutlookMail = Nothing
            Set OutlookApp = Nothing

        Next sh
    Next i

End Sub

Answer 1

很容易看出您在此代码中获得了 16 个结果（或电子邮件），因为您使用了两个 4 次循环。基本上，您的 For i 循环就是重复您的 For every 循环四次。

我要做的就是删除您的 For i 循环，并可能稍后在代码中添加验证（if-then）以验证将结果发送到哪个电子邮件地址。为了方便起见并保持简单，我现在只添加一个计数器。

Sub PDF_to_Email_2022_03_07()    

'ActiveWorkbook.Worksheets("ABC Therapy).Select         Email for ABC Therapy is 
`"[email protected]"`
'ActiveWorkbook.Worksheets("Achieve Therapy").Select    Email for Achieve Therapy is 
`"[email protected]"`
'ActiveWorkbook.Worksheets("Barb Therapy").Select       Email for Barb Therapy is 
`"[email protected]"`
'ActiveWorkbook.Worksheets("Felisa, Robin V.").Select   Email for Felisa, Robin V. is 
`"[email protected]"`


Dim sh As Variant
Dim strNames(1 To 4) As String
Dim counter as integer
counter=1

strNames(1) = "[email protected]"
strNames(2) = "[email protected]"
strNames(3) = "[email protected]"
strNames(4) = "[email protected]"




For Each sh In Array _
("ABC Therapy", "Achieve Therapy", "Barb Therapy", "Felisa, Robin V.")
    
Sheets(sh).Select



Dim Wb As Workbook
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
On Error Resume Next

Set Wb = Application.ActiveWorkbook
FileName = Wb.FullName

xIndex = VBA.InStrRev(FileName, ".")   


If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 24)


FileName = FileName & "_" + ActiveSheet.Name & ".pdf"   


ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail

    
.To = strNames(counter)
counter=counter+1    
    
        
.CC = ""
.BCC = ""
.Subject = "EI Payment Report"
.Body = "Enclosed is your monthly Report." 
.Attachments.Add FileName
.Display

End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing


Next sh

End Sub

Answer 2

我之前在删除 PDF 时遇到过文件锁定问题。我不会删除 PDF，而是将它们保存到

Environ("Temp")

目录中的文件夹中。

Sub PDF_to_Email_2022_03_07()
    Const Subject As String = "EI Payment Report"
    Const Body As String = "Enclosed is your monthly Report."
    Dim SheetNames As Variant
    SheetNames = Array("ABC Therapy", "Achieve Therapy", "Barb Therapy", "Felisa, Robin V.")
    
    Dim strNames(1 To 4) As String
    strNames(1) = "[email protected]"
    strNames(2) = "[email protected]"
    strNames(3) = "[email protected]"
    strNames(4) = "[email protected]"

    Dim i As Long

    For i = 0 To 3
        GetPDFEmail ws:=Worksheets(SheetNames(i)), ToAddress:=strNames(i), Subject:=Subject, Body:=Body
    Next i

End Sub

Function GetPDFEmail(ws As Worksheet, Optional ToAddress As String, Optional CC As String, Optional BCC As String, Optional Subject As String, Optional Body As String, Optional Display As Boolean = True)
    Dim FileName As String
    FileName = PDFFileName(ActiveWorkbook, ws)
    ws.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
    
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail
        .To = ToAddress
        .CC = CC
        .BCC = BCC
        .Subject = "EI Payment Report"
        .Body = "Enclosed is your monthly Report."
        .Attachments.Add FileName
        .Display
    End With
    Kill FileName
End Function

Function PDFFileName(wb As Workbook, ws As Worksheet) As String
    Dim xIndex As Long
    xIndex = VBA.InStrRev(wb.FullName, ".")
    PDFFileName = VBA.Left(wb.FullName, xIndex - 24) & "_" + ws.Name & ".pdf"
End Function