VBA 打印为 PDF 并使用自动文件名保存

Posted 2023-02-24

【中文标题】VBA 打印为 PDF 并使用自动文件名保存

【英文标题】：VBA Print to PDF and Save with Automatic File Name

【发布时间】：2015-01-28 22:48:26

【问题描述】：

我有一个代码可以将工作表中的选定区域打印到PDF，并允许用户选择文件夹并输入文件名。

不过有两件事我想做：

有没有一种方法可以让 PDF 文件在用户桌面上创建一个文件夹并使用基于工作表中特定单元格的文件名保存文件？ 如果将同一工作表的多个副本保存/打印为 PDF，则每个副本可以有一个编号，例如。 2, 3 在文件名中根据拷贝数？**

这是我目前的代码：

Sub PrintRentalForm()
Dim filename As String

Worksheets("Rental").Activate


filename = Application.GetSaveAsFilename(InitialFileName:="", _
                                     FileFilter:="PDF Files (*.pdf), *.pdf", _
                                     Title:="Select Path and Filename to save")

If filename <> "False" Then
With ActiveWorkbook
    .Worksheets("Rental").Range("A1:N24").ExportAsFixedFormat Type:=xlTypePDF, _
                                              filename:=filename, _
                                              Quality:=xlQualityStandard, _
                                              IncludeDocProperties:=True, _
                                              IgnorePrintAreas:=False, _
                                              OpenAfterPublish:=True
End With
End If


filename = Application.GetSaveAsFilename(InitialFileName:="", _
                                     FileFilter:="PDF Files (*.pdf), *.pdf", _
                                     Title:="Select Path and Filename to save")

If filename <> "False" Then
With ActiveWorkbook
    .Worksheets("RentalCalcs").Range("A1:N24").ExportAsFixedFormat Type:=xlTypePDF, _
                                              filename:=filename, _
                                              Quality:=xlQualityStandard, _
                                              IncludeDocProperties:=True, _
                                              IgnorePrintAreas:=False, _
                                              OpenAfterPublish:=False
End With
End If

End Sub`

更新： 我已经更改了代码和引用，它现在可以工作了。我已将代码链接到租赁表上的命令按钮 -

Private Sub CommandButton1_Click()
Dim filenamerental As String
Dim filenamerentalcalcs As String
Dim x As Integer


x = Range("C12").Value
Range("C12").Value = x + 1

Worksheets("Rental").Activate

Path = CreateObject("WScript.Shell").specialfolders("Desktop")

filenamerental = Path & "\" & Sheets("Rental").Range("O1")

'ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
Worksheets("Rental").Range("A1:N24").Select
Selection.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=filenamerental, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

Worksheets("RentalCalcs").Activate

Path = CreateObject("WScript.Shell").specialfolders("Desktop")

filenamerentalcalcs = Path & "\" & Sheets("RentalCalcs").Range("O1")

'ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
Worksheets("RentalCalcs").Range("A1:N24").Select
Selection.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=filenamerentalcalcs, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

Worksheets("Rental").Activate
Range("D4:E4").Select

End Sub

【参考方案1】：

希望这是不言自明的。使用代码中的 cmets 来帮助了解正在发生的事情。将单个单元格传递给此函数。该单元格的值将是基本文件名。如果单元格包含“AwesomeData”，那么我们将尝试在当前用户桌面上创建一个名为 AwesomeData.pdf 的文件。如果已经存在，请尝试 AwesomeData2.pdf 等等。在您的代码中，您可以将行 filename = Application..... 替换为 filename = GetFileName(Range("A1"))

Function GetFileName(rngNamedCell As Range) As String
    Dim strSaveDirectory As String: strSaveDirectory = ""
    Dim strFileName As String: strFileName = ""
    Dim strTestPath As String: strTestPath = ""
    Dim strFileBaseName As String: strFileBaseName = ""
    Dim strFilePath As String: strFilePath = ""
    Dim intFileCounterIndex As Integer: intFileCounterIndex = 1

    ' Get the users desktop directory.
    strSaveDirectory = Environ("USERPROFILE") & "\Desktop\"
    Debug.Print "Saving to: " & strSaveDirectory

    ' Base file name
    strFileBaseName = Trim(rngNamedCell.Value)
    Debug.Print "File Name will contain: " & strFileBaseName

    ' Loop until we find a free file number
    Do
        If intFileCounterIndex > 1 Then
            ' Build test path base on current counter exists.
            strTestPath = strSaveDirectory & strFileBaseName & Trim(Str(intFileCounterIndex)) & ".pdf"
        Else
            ' Build test path base just on base name to see if it exists.
            strTestPath = strSaveDirectory & strFileBaseName & ".pdf"
        End If

        If (Dir(strTestPath) = "") Then
            ' This file path does not currently exist. Use that.
            strFileName = strTestPath
        Else
            ' Increase the counter as we have not found a free file yet.
            intFileCounterIndex = intFileCounterIndex + 1
        End If

    Loop Until strFileName <> ""

    ' Found useable filename
    Debug.Print "Free file name: " & strFileName
    GetFileName = strFileName

End Function

如果您需要单步执行代码，调试行将帮助您弄清楚发生了什么。根据需要删除它们。我对变量有点疯狂，但这是为了尽可能清楚地说明这一点。

行动中

我的单元格 O1 包含不带引号的字符串“FileName”。使用这个 sub 调用我的函数并保存了一个文件。

Sub Testing()
    Dim filename As String: filename = GetFileName(Range("o1"))

    ActiveWorkbook.Worksheets("Sheet1").Range("A1:N24").ExportAsFixedFormat Type:=xlTypePDF, _
                                              filename:=filename, _
                                              Quality:=xlQualityStandard, _
                                              IncludeDocProperties:=True, _
                                              IgnorePrintAreas:=False, _
                                              OpenAfterPublish:=False
End Sub

您的代码参考其他所有内容的位置在哪里？如果您还没有制作一个模块，也许您需要制作一个模块并将您现有的代码移到那里。

【讨论】：

感谢以上内容-我有点理解，但复制并粘贴了以上内容，并将我的文件名代码更改为“filename = GetFileName(Range("O1"))”，我是在我的代码的第一个 If 语句中出现 1004 错误。更新 - 我将范围内的 O1 更改为 A1 并且它有效 - 但是我想将文件保存为单元格 O1 中的名称

现在也只是打印其中一个选项卡，而不是两个。

你的 If 语句有缺陷，除非你真的在比较字符串 false。 If filename <> "" Then 在这种情况下通常就足够了。您有两个工作表代码部分。我的功能不会以任何方式影响它们。您需要根据需要更新filename 的两个引用。此外，根据调用此代码的位置，您可能需要引用工作表 filename = GetFileName(Sheets("Rental").Range("O1")) 例如。再调试一些，让我知道。

对不起，我对 VBA 还是很陌生，不确定我哪里出错了。我仍然收到 1004 错误。我删除了 IF 语句并更改了字符串名称 - Worksheets("Rental").Activate filenamerental = GetFileName(Sheets("Rental").Range("O1")) With ActiveWorkbook .Worksheets("Rental").Range(" A1:N24").ExportAsFixedFormat 类型：=xlTypePDF，_ 文件名：= 文件名出租，_ 质量：=xlQualityStandard，_ IncludeDocProperties:=True，_ IgnorePrintAreas:=False，_ OpenAfterPublish:=False 以

结尾

避免将代码放入 cmets。有时非常难以阅读。更新问题。我刚刚测试过，没有任何问题。我已经更新了我的答案。