合并两个Excel VBA代码（另存为PDF +通过Outlook发送）

好心我有一个两个VBA代码之一是保存打印区域为与工作簿同名的PDF和保存文件位置是桌面，它工作正常，我有另一个代码，启动Outlook新消息，并采取一些特定的单元格价值作为主体，另一个价值体现。

问题是我想要新邮件的代码附加从代码1保存的PDF文件，并使主题相同的PDF文件名。

保存pdf代码是：

 Sub Save_as_pdf() Dim FSO As Object Dim s(1) As String Dim sNewFilePath As String Set FSO = CreateObject("Scripting.FileSystemObject") s(0) = "C:\Users\" & Environ("UserName") & "\Desktop\" & ThisWorkbook.Name If FSO.FileExists(ThisWorkbook.FullName) Then '//Change Excel Extension to PDF extension in FilePath s(1) = FSO.GetExtensionName(s(0)) If s(1) <> "" Then s(1) = "." & s(1) sNewFilePath = Replace(s(0), s(1), ".pdf") '//Export to PDF with new File Path ActiveSheet.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=sNewFilePath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False End If Else '//Error: file path not found MsgBox "Error: this workbook may be unsaved. Please save and try again." End If Set FSO = Nothing End Sub 

…第二个新的电子邮件代码是：

 Private Declare Function ShellExecute Lib "shell32.dll" _ Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _ ByVal nShowCmd As Long) As Long Sub SendEMail() Dim Email As String, Subj As String Dim Msg As String, URL As String Email = " " Subj = "PO # " & "-" & Cells(9, 5) & "-" & Cells(15, 2) & "-" & Cells(15, 8) & Cells(15, 7) Msg = " " Msg = "Dear Mr. " & vbCrLf & vbCrLf & "Good Day" & vbCrLf & vbCrLf & "Kindly find the attahched PO to be delivered to " & Cells(10, 12) 'Replace spaces with %20 (hex) Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20") Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20") 'Replace carriage returns with %0D%0A (hex) Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A") 'Create the URL URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg 'Execute the URL (start the email client) ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus 'Wait two seconds before sending keystrokes 'Application.Wait (Now + TimeValue("0:00:02")) 'Application.SendKeys "%s" End Sub 

我希望我能澄清我的问题。 提前致谢。

Answer 1

你可以试试这个：它将PDF导出改为一个函数来获取文件path，并将其用作另一个文件的参数。 URL方法不适用于附件，所以下面是Outlook的一些代码（ 编辑包含整个代码 ）

使用Outlook准备邮件（对于法语评论抱歉）：

 Sub Send_To_Pdf() Dim PdfPath As String Dim BoDy As String BoDy = Msg = "Dear Mr. " & vbCrLf & vbCrLf & "Good Day" & vbCrLf & vbCrLf & "Kindly find the attahched PO to be delivered to " & Cells(10, 12) PdfPath = Save_as_pdf EnvoiMail Right(PdfPath, InStr(1, StrReverse(PdfPath), "\") - 1), "[e-mail];[e-mail]", , , BoDy, 1, PdfPath End Sub Public Function Save_as_pdf() As String Dim FSO As Object Dim s(1) As String Dim sNewFilePath As String Set FSO = CreateObject("Scripting.FileSystemObject") s(0) = "C:\Users\" & Environ("UserName") & "\Desktop\" & ThisWorkbook.Name If FSO.FileExists(ThisWorkbook.FullName) Then '//Change Excel Extension to PDF extension in FilePath s(1) = FSO.GetExtensionName(s(0)) If s(1) <> "" Then s(1) = "." & s(1) sNewFilePath = Replace(s(0), s(1), ".pdf") '//Export to PDF with new File Path ActiveSheet.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=sNewFilePath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False End If Else '//Error: file path not found MsgBox "Error: this workbook may be unsaved. Please save and try again." End If Set FSO = Nothing Save_as_pdf = sNewFilePath End Function Sub EnvoiMail(Subject As String, Destina As String, Optional CCdest As String, Optional CCIdest As String, Optional BoDyTxt As String, Optional NbPJ As Integer, Optional PjPaths As String) Dim MonOutlook As Object Dim MonMessage As Object Set MonOutlook = CreateObject("Outlook.Application") Set MonMessage = MonOutlook.createitem(0) Dim PJ() As String PJ() = Split(PjPaths, ";") With MonMessage .Subject = Subject '"Je suis content" .To = Destina '"[e-mail];[e-mail]" .cc = CCdest '"[e-mail];[e-mail]" .bcc = CCIdest '"[e-mail];[e-mail]" .BoDy = BoDyTxt If PjPaths <> "" And NbPJ <> 0 Then For i = 0 To NbPJ - 1 'MsgBox PJ(I) .Attachments.Add PJ(i) '"C:\Mes Documents\Zoulie Image.gif" Next i End If .display '.send '.Attachments.Add ActiveWorkbook.FullName End With '?plusieurs?MonMessage.Attachments.Add "D:\Prof\Janvier\Base clients.mdb" Set MonOutlook = Nothing End Sub