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 = "[e-mail]"
.Subject = "my Subject - To be adapted!"
.Body = " Please find... "
.Attachments.Add myFile
.Display
' .Send
End With
End If

Next i

结束子

Answer 1

建议

1. 当在Excel中处理行时，使用Long而不是Integer。你可能会得到一个溢出错误。
2. 创建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 = "[e-mail]"
.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 = "[e-mail]"
.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