发送带有多个pdf附件的电子邮件

Question

我正在尝试发送多个pdf文件(每次发送的数量不同(。

我有代码，它可以在不同的电子表格中工作，只需附加一个文件，但在这个电子表格上不起作用，即使pdf是使用与附件相同的单元格中的名称创建的。

我有一个所有文件的列表要附在"；a"；从第14行开始，并且需要附加1-10个文件，直到单元格为空。

一个在其他地方工作的附件的代码：

Private Sub CommandButton1_Click()
On Error GoTo ErrHandler

' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")

' CREATE EMAIL OBJECT.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
Dim Path As String
Dim FileName1 As String

Path = "C:UsersFile Folder"
FileName1 = Range("A14")

PathFileName = ThisWorkbook.Path & "" & FileName1 & ".pdf"

With objEmail
.SentOnBehalfOfName = "[e-mail]"
.To = "[e-mail]"
.Subject = FileName1
.Body = "Have a nice day!"

.Attachments.Add PathFileName
.Display        ' Display the message in Outlook.
End With

' CLEAR.
Set objEmail = Nothing:    Set objOutlook = Nothing

ErrHandler:
'
End Sub

Answer 1

试试这个：

Private Sub CommandButton1_Click()
Const FLDR = "C:UsersFile Folder" 'files are here
Dim objOutlook As Object
Dim objEmail As Object, cFile As Range
Dim fPath As String

On Error GoTo ErrHandler
Set objOutlook = CreateObject("Outlook.Application") 'edit: fixed position
Set objEmail = objOutlook.CreateItem(olMailItem)

Set cFile = ActiveSheet.Range("A14") 'cell with first file name

With objEmail
.SentOnBehalfOfName = "[e-mail]"
.To = "[e-mail]"
.Subject = "Attached file(s)"
.Body = "Have a nice day!"
'check each file, and add if found
Do While Len(cFile.Value) > 0
fPath = FLDR & cFile.Value & ".pdf"
If Len(Dir(fPath)) > 0 Then   'check if file exists
.Attachments.Add fPath
Else
MsgBox "File not found" & vbLf & fPath, vbExclamation
End If
Set cFile = cFile.Offset(1) 'next file
Loop
.Display        ' Display the message in Outlook.
End With

Exit Sub
ErrHandler:
Debug.Print Err.Description

End Sub