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

Question

在尝试将当前 Excel 工作表另存为 PDF 时，我的一些 VBA 代码遇到了奇怪的行为。

以下代码在装有 Excel 365 ProPlus 版本 1803（内部版本 9126.2336）的 Windows 7 机器上运行良好，但在另一台装有 Excel 365 版本 1901（内部版本 11231.20174）的 Windows 7 机器上运行时遇到错误 1004。

任何建议，错误的原因可能是什么？

编辑（晚上 10:04）：

我尝试在两台不同机器上的完全相同的文件夹中使用完全相同的文件，唯一的区别似乎是 Excel 的版本。在“较旧”的 Excel 365 版本上一切正常，而在较新的版本上我遇到了错误。

错误发生在最后一个名为“PDFActiveSheet”的 Sub 中的以下代码行：

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

在我的测试机器上，当我遇到错误时，String fsFileName 具有以下值：

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

这个想法是，用户选择一个文件夹（其中包含一个或多个 .tsv 文件），然后宏打开并更改这些 tsv 文件中的每一个以成为 Amazon FBA 就绪的 EAN 列表，然后将所有内容保存为 PDF。这是我的完整代码：

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

问题可能是输出文件夹不存在。试试这个：

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