打印到 PDF 宏神秘地停止工作

打印到 PDF 宏神秘地停止工作

大约一周前,我的打印宏停止工作了。它如下所示:

Function Create_PDF(Myvar As Object, FixedFilePathName As String, _ OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String Dim FileFormatstr As String Dim FName As Variant

'Test If the Microsoft Add-in is installed
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
     & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

    If FixedFilePathName = "" Then
        'Open the GetSaveAsFilename dialog to enter a file name for the pdf
        FileFormatstr = "PDF Files (*.pdf), *.pdf"
        FName = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                                              Title:="Create PDF")

        'If you cancel this dialog Exit the function
        If FName = False Then Exit Function
    Else
        FName = FixedFilePathName
    End If

    'If OverwriteIfFileExist = False we test if the PDF
    'already exist in the folder and Exit the function if that is True
    If OverwriteIfFileExist = False Then
        If Dir(FName) <> "" Then Exit Function
    End If

    'Now the file name is correct we Publish to PDF
    On Error Resume Next
    Myvar.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            FileName:=FName, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=OpenPDFAfterPublish
    On Error GoTo 0

    'If Publish is Ok the function will return the file name
    If Dir(FName) <> "" Then Create_PDF = FName
End If

End Function 

Sub SaveThisReport()

Dim MyFolder As String
Dim MyFile As String
Dim PDFname As String
Dim FileName As String

On Error Resume Next
MyFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & "PDF Reports"
MkDir MyFolder
On Error GoTo 0

PDFname = ActiveSheet.Range("SelectedSchool").Value
MyFile = MyFolder & Application.PathSeparator & PDFname
FileName = Create_PDF(ActiveSheet.Range("ReportArea"), MyFile, True, False)
Range("A1").Select

包含宏的工作簿可以下载这里

答案1

当前状态下的 VBA 代码的 SaveThisReport() 部分毫无用处,因为,

  • 您尚未定义变量“精选学校”代码中的任何地方。
    • 自从PDF名称所选学校实际上做的是相同的事,所以是多余的。
  • 您尚未定义变量“报告区域”代码中的任何地方。

因为FileName = Create_PDF(ActiveSheet.Range("ReportArea"), MyFile, True, False)对象是 ActiveSheet 所以FileName = Create_PDF(ActiveSheet, MyFile, True, False)就足够了。


尝试这个

Sub SaveThisReport()

    Dim MyFolder As String
    Dim MyFile As String
    Dim PDFname As String
    Dim FileName As String
    Dim ReportArea As String

    'Initialise your pdfname variable
    'From your comment you've identified D2 as the file name.
    PDFname = ActiveSheet.Range("D2").Value 

    On Error Resume Next
        MyFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & "PDF Reports"
        MkDir MyFolder
    On Error GoTo 0

    MyFile = MyFolder & Application.PathSeparator & PDFname
    FileName = Create_PDF(ActiveSheet, MyFile, True, False)
    Range("A1").Select

End Sub

笔记:ActiveSheet 仅指当前活动的工作表!因此,如果您尝试在另一张工作表上使用它,它将引用当前工作表中的“D2”。最好确定哪张特定工作表包含您需要的信息PDFname = Sheets("YOURSHEETNAMEHERE").Range("D2").Value

附加说明:确保当你复制和粘贴上面的代码中,你正在更改函数名称创建_PDF引用正确的函数名称,如下所示。

Function Create_PDF(Myvar As Object, FixedFilePathName As String, _
                OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
Dim FileFormatstr As String
Dim FName As Variant

'Test If the Microsoft Add-in is installed
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
     & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

    If FixedFilePathName = "" Then
        'Open the GetSaveAsFilename dialog to enter a file name for the pdf
        FileFormatstr = "PDF Files (*.pdf), *.pdf"
        FName = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                                              Title:="Create PDF")

        'If you cancel this dialog Exit the function
        If FName = False Then Exit Function
    Else
        FName = FixedFilePathName
    End If

    'If OverwriteIfFileExist = False we test if the PDF
    'already exist in the folder and Exit the function if that is True
    If OverwriteIfFileExist = False Then
        If Dir(FName) <> "" Then Exit Function
    End If

    'Now the file name is correct we Publish to PDF
    On Error Resume Next
    Myvar.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            FileName:=FName, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=OpenPDFAfterPublish
    On Error GoTo 0

    'If Publish is Ok the function will return the file name
    If Dir(FName) <> "" Then Create_PDF = FName
End If
End Function

相关内容