Excel VBA - 将 PDF 保存到一封电子邮件中，而不是创建多个单独的电子邮件

Question

我正在尝试将多个 PDF 保存到一个电子邮件附件中。然而，下面的代码是为每个 PDF 创建一个电子邮件。我想将我所有的 PDF 附加到一封电子邮件中。

发邮件()

Dim WksAct As Worksheet
Dim LastRow As Integer, i As Integer
Dim MySheet As String, myFile As String
Dim OutlookApp As Object, MItem As Object

Set WksAct = ThisWorkbook.Sheets("Activity")
LastRow = WksAct.Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To LastRow
    
    If WksAct.Range("B" & i).Value < 0 Then
        MySheet = WksAct.Range("A" & i).Value
        myFile = ThisWorkbook.Path & "\" & MySheet & ".pdf"
        Sheets(MySheet).ExportAsFixedFormat _
                                            Type:=xlTypePDF, _
                                            Filename:=myFile, _
                                            Quality:=xlQualityStandard, _
                                            IncludeDocProperties:=True, _
                                            IgnorePrintAreas:=False, _
                                            OpenAfterPublish:=False
        
        Set OutlookApp = CreateObject("Outlook.Application")
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = "test@mail.com"
            .Subject = "my Subject - To be adapted!"
            .Body = " Please find... "
            .Attachments.Add myFile
            .Display
            ' .Send
        End With
    End If
    
Next i

结束子

Answer 1

建议

处理 Excel 中的行时，请使用 Long 而不是 Integer。您可能会遇到溢出错误。
一次性创建 Outlook 对象，而不是循环执行。

代码

Option Explicit

Sub Mail()
    Dim WksAct As Worksheet
    Dim LastRow As Long, i As Integer
    Dim MySheet As String, myFile As String
    Dim OutlookApp As Object, MItem As Object
    
    '~~> Work with Outlook Object
    Set OutlookApp = CreateObject("Outlook.Application")
    '~~> Create the email
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
        .To = "test@mail.com"
        .Subject = "my Subject - To be adapted!"
        .Body = " Please find... "
    End With
    
    Set WksAct = ThisWorkbook.Sheets("Activity")
    
    With WksAct
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row

        For i = 1 To LastRow
            If .Range("B" & i).Value2 < 0 Then
                MySheet = .Range("A" & i).Value2
                
                myFile = ThisWorkbook.Path & "\" & MySheet & ".pdf"
                
                Sheets(MySheet).ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:=myFile, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
                
                '~~> Give time for the save to happen
                DoEvents
                
                '~~> Attach the file
                MItem.Attachments.Add myFile
            End If
        Next i
    End With
    
    '~~> Show the email
    MItem.Display
End Sub

备选

另一种方法是在最后创建电子邮件并一次性添加所有 pdf。例如：

Option Explicit

Sub Mail()
    Dim WksAct As Worksheet
    Dim LastRow As Long, i As Integer
    Dim MySheet As String, myFile As String
    Dim OutlookApp As Object, MItem As Object
           
    Set WksAct = ThisWorkbook.Sheets("Activity")
    
    With WksAct
        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row

        For i = 1 To LastRow
            If .Range("B" & i).Value2 < 0 Then
                MySheet = .Range("A" & i).Value2
                
                myFile = ThisWorkbook.Path & "\" & MySheet & ".pdf"
                
                Sheets(MySheet).ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:=myFile, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
                
                '~~> Give time for the save to happen
                DoEvents
            End If
        Next i
    End With
    
    Dim StrFile As String
    
    '~~> Check if any pdfs were created and then
    '~~> create the email
    StrFile = Dir(ThisWorkbook.Path & "\*.pdf")
    If StrFile <> "" Then
        '~~> Work with Outlook Object
        Set OutlookApp = CreateObject("Outlook.Application")
        '~~> Create the email
        Set MItem = OutlookApp.CreateItem(0)
        With MItem
            .To = "test@mail.com"
            .Subject = "my Subject - To be adapted!"
            .Body = " Please find... "
        
            '~~> Loop through all pdf and then add them
            Do While Len(StrFile) > 0
                MItem.Attachments.Add ThisWorkbook.Path & "\" & StrFile
                StrFile = Dir
            Loop

            '~~> Show the email
            .Display
        End If
    End If
End Sub

Excel VBA - 将 PDF 保存到一封电子邮件中，而不是创建多个单独的电子邮件

Excel VBA - Save PDFs into one email instead of creating multiple separate emails

pdf

excel

vba