如何使用 Excel VBA 将当前工作表保存为 PDF 和 Outlook 电子邮件？

Question

我的任务是查找或创建一个新的宏模块，它将仅将当前工作表保存为 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

总之，您在附加的代码中拥有所需的一切：

删除这是选择目的地的提示。

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 功能将不起作用。

休息应该没问题。