VBA打印到PDF，并保存与自动文件名

I have a code that prints a selected area in a worksheet to PDF and allows user to select folder and input file name.

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

There are two things I want to do though:

但我想做两件事:

1. Is there a way that the PDF file can create a folder on the users desktop and save the file with a file name based on specific cells in the sheet?
2. 是否有一种方法可以让PDF文件在用户桌面上创建一个文件夹，并基于表中的特定单元格将文件保存为文件名?
3. If multiple copies of the same sheet are saved/printed to PDF can each copy have a number eg. 2, 3 in the filename based on the copy number?**
4. 如果同一页的多个副本被保存/打印为PDF，每个副本可以有一个数字。在文件名中基于拷贝数?**

Here is the code I have so far:

下面是我到目前为止的代码:

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`

UPDATE: I have changed the code and references and it now works. I have linked the code to a commandbutton on the Rental Sheet -

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

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 个解决方案

#1

Hopefully this is self explanatory enough. Use the comments in the code to help understand what is happening. Pass a single cell to this function. The value of that cell will be the base file name. If the cell contains "AwesomeData" then we will try and create a file in the current users desktop called AwesomeData.pdf. If that already exists then try AwesomeData2.pdf and so on. In your code you could just replace the lines filename = Application..... with filename = GetFileName(Range("A1"))

希望这足够解释了。使用代码中的注释来帮助理解正在发生的事情。将一个单元格传递给这个函数。该单元格的值将是基文件名。如果单元格包含“AwesomeData”，那么我们将尝试在当前的用户桌面中创建一个名为AwesomeData.pdf的文件。如果已经存在，那么尝试AwesomeData2。pdf等等。在您的代码中，您可以替换为filename = Application…文件名= GetFileName(范围(" 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

The debug lines will help you figure out what is happening if you need to step through the code. Remove them as you see fit. I went a little crazy with the variables but it was to make this as clear as possible.

调试行将帮助您了解如果需要逐步执行代码将会发生什么。按你认为合适的方式移除它们。我对变量有点疯狂，但这是为了让它尽可能清晰。

In Action

在行动

My cell O1 contained the string "FileName" without the quotes. Used this sub to call my function and it saved a file.

我的单元格O1包含没有引号的字符串“文件名”。使用这个子函数调用我的函数，它保存了一个文件。

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

Where is your code located in reference to everything else? Perhaps you need to make a module if you have not already and move your existing code into there.

你的代码在哪里?如果还没有的话，您可能需要创建一个模块，并将现有代码移动到其中。