Странное поведение с макросом SaveAs PDF в разных сборках Excel - PullRequest
Новая
       3

Странное поведение с макросом SaveAs PDF в разных сборках Excel

0 голосов
/ 07 марта 2019

Я испытываю странное поведение с некоторым моим кодом VBA при попытке сохранить текущую рабочую таблицу Excel в формате PDF.

Следующий код прекрасно работает на компьютере с Windows 7 с Excel 365 ProPlus, версия1803 (сборка 9126.2336), но с ошибкой 1004 на другом компьютере Windows 7 с Excel 365, версия 1901 (сборка 11231.20174).

Любой совет, что может быть причиной ошибки?

РЕДАКТИРОВАТЬ (10:04 вечера):

Я пробовал это с одинаковыми файлами в тех же папках на двух разных машинах, единственное отличие, похоже, версия Excel,Все отлично работает на «старой» сборке Excel 365, а на более новой я сталкиваюсь с ошибкой.

Ошибка возникает в следующей строке кода в последнем подпункте, называемом «PDFActiveSheet»: 

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

1 Ответ

0 голосов
/ 07 марта 2019

Проблема может заключаться в том, что выходная папка не существует. Попробуйте это: 

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
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...