Strange behaviour with SaveAs PDF macro on different Excel builds

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

In which line do you get the error? And what is the exact value of `fsFileName` at the time of error. — Pᴇʜ, Mar 07 '19 at 16:00
Are you sure it works with the hardcoded username `Testuser` on all computers? Maybe try with something like `fsFileName = environ("USERPROFILE") & "\Downloads\Test\testfile.tsv"` - plus you have to ensure that the `Downloads\Test`-folder exits. — FunThomas, Mar 07 '19 at 16:08
Hey guys, thanks, I updated the initial post and inserted the full code.In reality, there is no hard coded folder path, as the user of the macro gets to choose the folder and its path before hand. — tisch84, Mar 07 '19 at 21:25

Dimich · Answer 1 · 2019-03-07T16:30:15.177

0

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

edited Mar 07 '19 at 16:30

answered Mar 07 '19 at 16:09

Dimich

359
1
9

Two problems: **1** Will fail if folder `Download` is missing, for a way to create folders and subfolders, see https://stackoverflow.com/questions/10803834/is-there-a-way-to-create-a-folder-and-sub-folders-in-excel-vba **2** Will fail if the current userProfile is not stored in `C:\Users\testuser` - it can be stored on a different drive, and there are cases where the name of the profile folder is not identical to the username. – FunThomas Mar 07 '19 at 16:18
You're right, looks like MkDir doesn't create directories recursively. And for the drive and user profile, I believe Tim got that part figured out :) I updated my answer to create directories recursively. Used this example: https://stackoverflow.com/a/33671329/11162180 – Dimich Mar 07 '19 at 16:32
Hey guys, thanks for your answer and comments, I just updated the initial post to reflect my full code. I already had inserted the check for the folder being existent in a different sub, so that should not be the problem (and the Output folders are there and existent on both of my test machinesI just double checked). Any other ideas? Thanks! – tisch84 Mar 07 '19 at 21:30
RIght here: wsA.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=fsFileName, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False – tisch84 Mar 07 '19 at 22:10
Not sure what the problem may be. Check if the address/file name has any illegal characters. Try to hardcode the output folder address to fsFileName right before line 5 see if that works. Also, make sure you're not exporting a blank sheet as that may also fail. – Dimich Mar 08 '19 at 02:33

Strange behaviour with SaveAs PDF macro on different Excel builds

1 Answers1