如何使用 Excel VBA 将当前 sheet 保存为 PDF 并通过 Outlook 发送电子邮件？

Question

我的任务是查找或创建一个新的宏模块，它将仅将当前 sheet 保存为 PDF 格式（到临时文件夹）。

所有我能找到的接近我想做的就是我所附的。这会提示用户输入保存位置。

如何将其更改为不提示保存位置并保存到临时文件夹，然后通过 Outlook 在电子邮件中附加 pdf。

Sub Saveaspdfandsend()
    Dim xSht As Worksheet
    Dim xFileDlg As FileDialog
    Dim xFolder As String
    Dim xYesorNo As Integer
    Dim xOutlookObj As Object
    Dim xEmailObj As Object
    Dim xUsedRng As Range
 
    Set xSht = ActiveSheet
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
 
    If xFileDlg.Show = True Then
       xFolder = xFileDlg.SelectedItems(1)
    Else
       MsgBox "You must specify a folder to save the PDF into." & vbCrLf & 
    vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify 
    Destination Folder"
       Exit Sub
    End If
    xFolder = xFolder + "\" + xSht.Name + ".pdf"
 
    'Check if file already exist
    If Len(Dir(xFolder)) > 0 Then
        xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & 
    "Do you want to overwrite it?", _
                          vbYesNo + vbQuestion, "File Exists")
        On Error Resume Next
        If xYesorNo = vbYes Then
            Kill xFolder
        Else
            MsgBox "if you don't overwrite the existing PDF, I can't 
    continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", 
    vbCritical, "Exiting Macro"
            Exit Sub
        End If
        If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file 
    is not open or write protected." _
                        & vbCrLf & vbCrLf & "Press OK to exit this macro.", 
    vbCritical, "Unable to Delete File"
            Exit Sub
        End If
    End If
 
    Set xUsedRng = xSht.UsedRange
    If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
        'Save as PDF file
        xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, 
    Quality:=xlQualityStandard
     
        'Create Outlook email
        Set xOutlookObj = CreateObject("Outlook.Application")
        Set xEmailObj = xOutlookObj.CreateItem(0)
        With xEmailObj
        .Display
        .To = ""
        .CC = ""
        .Subject = xSht.Name + ".pdf"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            '.Send
        End If
    End With
    Else
      MsgBox "The active worksheet cannot be blank"
      Exit Sub
    End If
End Sub

Answer 1

总而言之，您已在所附代码中获得所需的一切：

删除这是select目的地的提示。

Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & 
vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify 
Destination Folder"
   Exit Sub
End If

删除此后，您必须将任一字符串添加到路径以保存文件，我建议为此使用一些单元格引用，就好像您编码时可能遇到问题一样。

然而，在以前删除的行的位置插入：

xFolder = C:\fullpath\filename.pdf

尽管我会建议：

xFolder = ThisWorkbook.Sheets("Setup").Range("A1") 'something in those lines, you could name sheet to be safer.

保留检查文件是否存在的部分，它可能会变得很方便，因为有时如果您使用共享驱动器，它们可能会被其他人阻止，并且 kill 功能将不起作用。

休息应该没问题。

如何使用 Excel VBA 将当前 sheet 保存为 PDF 并通过 Outlook 发送电子邮件？

How to save current sheet to PDF and email with Outlook using Excel VBA?

pdf

email

excel

outlook

vba