[英]VBA Print to PDF and Save with Automatic File Name
我有一个代码可以将工作表中的选定区域打印为PDF
并允许用户选择文件夹和输入文件名。
不过我想做两件事:
这是我到目前为止的代码:
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
希望这是不言自明的。 使用代码中的注释来帮助理解发生了什么。 将单个单元格传递给此函数。 该单元格的值将是基本文件名。 如果单元格包含“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
参考其他所有内容,您的代码位于何处? 也许您需要制作一个模块(如果您还没有)并将现有代码移到那里。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.