SaveAs PDF宏在不同Excel版本上的奇怪行为

Question

I am experiencing a strange behaviour with some VBA code of mine, when trying to save the current Excel Worksheet as PDF.

The following code works perfectly fine on a Windows 7 machine with Excel 365 ProPlus, Version 1803 (Build 9126.2336), but runs into an error 1004 on another Windows 7 machine with Excel 365, Version 1901 (Build 11231.20174).

Any advise, what could be the cause of the error?

EDIT (10:04 pm):

I tried this with the exact same files in the exact same folders on two different machines, the only difference seems to be the version of Excel. Everything works fine on the "older" Excel 365 build, while on the newer one I run into an error.

The error happens on the following line of code in the last Sub called "PDFActiveSheet":

wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=fsFileName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

On my test machine, at the moment I run into the error, the String fsFileName has the following value:

fsFileName : "C:\Users\Julchen\Downloads\Test\testfile.pdf" : String

The idea is, that the user chooses a folder (with one or more .tsv files inside), then the macro opens and alters each of these tsv files to become Amazon FBA ready EAN lists, and then saves everything as PDF. Here is my full code:

Option Explicit

Sub Pick_Folder()
    Dim fs As Object
    Dim fsFileName As Variant
    Dim fsDir As Object
    Dim sItem, s As String
    Dim fldr As FileDialog
    Dim Counter As Integer

'Let user choose the folder where the TSV files are stored
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Wählen Sie einen Ordner..."
    .AllowMultiSelect = False
    .InitialFileName = Application.DefaultFilePath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With

'Check if subfolder "Output" exists in chosen folder, if not then create it.
Set fs = CreateObject("Scripting.FileSystemObject")
Set fsDir = fs.getfolder(sItem)
If Not fs.FolderExists(sItem & "\Output") Then
    MkDir sItem & "\Output"
End If

'Cycle through all files in the chosen folder and open the alter macro to create EAN codes, then save the file as PDF and count how many files were processed.
Application.ScreenUpdating = False
Counter = 0
For Each fsFileName In fsDir.Files
    s = fsFileName
    Call Create_EAN_files(s)
    Call PDFActiveSheet(s)
    Application.DisplayAlerts = False
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Counter = Counter + 1
Next

Application.ScreenUpdating = True
MsgBox ("Finished! The macro created " & Counter & " PDF files in the following folder: " & Left(s, InStrRev(s, "\")))
Exit Sub
NextCode:
    Set fldr = Nothing
End Sub

---

Sub Create_EAN_files(fsFileName$)
Dim Entry As Integer
Dim EANText As String

    Workbooks.OpenText Filename:= _
        fsFileName, Origin:=65001, StartRow _
        :=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1)), _
        TrailingMinusNumbers:=True
    ActiveWindow.Zoom = 70
    Columns(1).ColumnWidth = 31.57
    Columns(2).ColumnWidth = 115
    ActiveWorkbook.ActiveSheet.Columns("C:D").Delete
    Columns(3).ColumnWidth = 22.71
    ActiveWorkbook.ActiveSheet.Columns("D:G").Delete
    Range("D1").EntireColumn.Insert
    Columns(4).ColumnWidth = 28
    Columns(5).ColumnWidth = 22

    For Entry = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 3).End(xlUp).End(xlUp).Row + 1 To ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
 ' Variables needed (remember to use "option explicit").   '
    Dim retval, s As String    ' This is the return string.      '
    Dim i As Integer        ' Counter for character position. '

    ' Initialise return string to empty                       '
    s = ActiveWorkbook.ActiveSheet.Cells(Entry, 3).Value
    retval = ""

    ' For every character in input string, copy digits to     '
    '   return string.                                        '
    For i = 1 To Len(s)
        If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
            retval = retval + Mid(s, i, 1)
        End If
    Next
    ' Then return the return string.                          '
    ActiveWorkbook.ActiveSheet.Cells(Entry, 3).Value = retval
    ActiveWorkbook.ActiveSheet.Cells(Entry, 3).NumberFormat = "0"
    EANText = ActiveWorkbook.ActiveSheet.Cells(Entry, 3).Value
    EANText = ean13N(EANText)
    ActiveWorkbook.ActiveSheet.Cells(Entry, 4).Value = EANText
    With ActiveWorkbook.ActiveSheet.Cells(Entry, 4).Font
        .Name = "Code EAN13"
        .Size = 50
    End With
    Next Entry

Columns(2).HorizontalAlignment = xlLeft
Columns(2).WrapText = True
Columns(3).HorizontalAlignment = xlCenter
Columns(5).HorizontalAlignment = xlCenter

Range(Cells(ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 3).End(xlUp).End(xlUp).Row, 1).Address, Cells(ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row, 5).Address).Select

    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.VerticalAlignment = xlCenter

ActiveSheet.PageSetup.RightHeader = "Picken:      [    ]" & Chr(10) & _
"Buchung:  [    ] " & Chr(10) & _
"EAN Etiketten Drucken : [    ]" & Chr(10) & _
"Kontrolle:  [    ]" & Chr(10) & _
"SC Etiketten Druck : [    ]" & Chr(10) & _
"SC als Versendet Markieren : [    ]" & Chr(10) & _
"End-Kontrolle : [    ]"

ActiveSheet.PageSetup.LeftFooter = "OA / Amazon FBA"
ActiveSheet.PageSetup.RightFooter = Date & " / " & Time()
ActiveSheet.PageSetup.Orientation = xlLandscape
ActiveSheet.PageSetup.PrintArea = Range(Cells(1, 1).Address, Cells(ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row, 5).Address).Address

Application.PrintCommunication = False
    ActiveSheet.PageSetup.FitToPagesWide = 1
    ActiveSheet.PageSetup.FitToPagesTall = False
Application.PrintCommunication = True

End Sub

---

Public Function ean13N(chaine)
    Dim i%, checksum%, first%, CodeBarre$, tableA As Boolean
    ean13N = ""

'   checking that all characters in the barcode are digits
    For i% = 1 To Len(chaine)
        If Asc(Mid$(chaine, i%, 1)) < 48 Or Asc(Mid$(chaine, i%, 1)) > 57 Then
            ean13N = ""
            Exit Function
        End If
    Next

'   Calculating the check digit
    If Len(chaine) = 12 Then
        For i% = 2 To 12 Step 2
            checksum% = checksum% + Val(Mid$(chaine, i%, 1))
        Next
        checksum% = checksum% * 3
        For i% = 1 To 11 Step 2
            checksum% = checksum% + Val(Mid$(chaine, i%, 1))
        Next
        chaine = chaine & (10 - checksum% Mod 10) Mod 10
    End If

'   developing the barcode string
    If Len(chaine) = 13 Then
    '   The first number is taken as is, the second is from Table A
        CodeBarre$ = Left$(chaine, 1) & Chr$(65 + Val(Mid$(chaine, 2, 1)))
        first% = Val(Left$(chaine, 1))
        For i% = 3 To 7
            tableA = False
            Select Case i%
                Case 3
                    Select Case first%
                Case 0 To 3
                    tableA = True
                End Select
            Case 4
                Select Case first%
                Case 0, 4, 7, 8
                    tableA = True
                End Select
            Case 5
                Select Case first%
                Case 0, 1, 4, 5, 9
                tableA = True
                End Select
            Case 6
                Select Case first%
                Case 0, 2, 5, 6, 7
                tableA = True
                End Select
            Case 7
                Select Case first%
                Case 0, 3, 6, 8, 9
                tableA = True
                End Select
            End Select

            If tableA Then
                CodeBarre$ = CodeBarre$ & Chr$(65 + Val(Mid$(chaine, i%, 1)))
            Else
                CodeBarre$ = CodeBarre$ & Chr$(75 + Val(Mid$(chaine, i%, 1)))
            End If
        Next

        CodeBarre$ = CodeBarre$ & "*"   'Adding central divider
        For i% = 8 To 13
            CodeBarre$ = CodeBarre$ & Chr$(97 + Val(Mid$(chaine, i%, 1)))
        Next
        CodeBarre$ = CodeBarre$ & "+"   'adding the terminating char
        ean13N = CodeBarre$
    End If
End Function

---

Sub PDFActiveSheet(fsFileName$)
Dim wsA As Worksheet
Dim wbA As Workbook

On Error GoTo errHandler

1  Set wbA = ActiveWorkbook
2  Set wsA = ActiveSheet

'create default name for savng file
3  fsFileName = Replace(fsFileName, ".tsv", ".pdf")
4  fsFileName = Left(fsFileName, InStrRev(fsFileName, "\")) & "Output\" & Right(fsFileName, Len(fsFileName) - InStrRev(fsFileName, "\"))

5  wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=fsFileName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file. Error on Line : " & Erl
    Resume exitHandler
End Sub

Answer 1

The problem could be that the output folder does not exist. Try this:

Sub PDFActiveSheet()

Dim wsA As Worksheet
Dim wbA As Workbook
Dim fsFileName, fsFolder As String
On Error GoTo errHandler

Set wbA = ActiveWorkbook
Set wsA = ActiveSheet

fsFolder = "C:\Users\testuser\Downloads\Test\"
fsFileName = "testfile.tsv"

'create default name for saving file
fsFolder = Left(fsFolder, InStrRev(fsFolder, "\")) & "Output\" & Right(fsFolder, Len(fsFolder) - InStrRev(fsFolder, "\"))

' create folder if it doesn't exist
If Len(Dir(fsFolder, vbDirectory)) = 0 Then
    CreateDir fsFolder
End If

fsFileName = fsFolder & Replace(fsFileName, ".tsv", ".pdf")

wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=fsFileName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file."
    Resume exitHandler
End Sub

Sub CreateDir(strPath As String)
    Dim elm As Variant
    Dim strCheckPath As String

    strCheckPath = ""
    For Each elm In Split(strPath, "\")
        strCheckPath = strCheckPath & elm & "\"
        If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
    Next
End Sub