Макрос печати в PDF загадочно перестал работать

Question

Примерно неделю назад мой макрос печати перестал работать. Вот как это выглядит:

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

Книгу с макросом можно скачать здесь.

Answer 1

Раздел SaveThisReport() вашего кода VBA в его текущем состоянии бесполезен, так как

• Вы не определили переменную "SelectedSchool" в вашем коде.
  • Поскольку PDFname и SelectedSchool фактически делают то же самое, это избыточно.
• Вы не определили переменную "ReportArea" в своем коде.

В 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").Диапазон ("D2").Значение

Дополнительное примечание . Убедитесь, что при копировании и вставке приведенного выше кода вы меняете имя функции Create_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