PDF Seitenanzahl feststellen

Hallo zusammen,
habe den Code irgendwo aus dem Internet und ein bischen angepasst.
Ich würde gerne bei einem mehrseitigen PDF die Seiten zählen.
Mit dem Makro schaffe ich aber nur die ersten paar Seiten aber nicht 100 oder 500.
Kann mir bitte jemand helfen ? Ich komm da irgendwie nicht weiter.
Was ist falsch im Code ?

Sub PDFCounter()
Dim buf As String, pfad As String, I As Integer
Dim DateiName As Object, pdf As Object, pos As Integer
'Datei Auswählen
pfad = Application.GetOpenFilename("Alle Dateien (*.*), *.*")
pfad = Mid(pfad, InStrRev(pfad, "\") + 1)
'Dateiname anzeigen
MsgBox (pfad)
Set DateiName = CreateObject("Scripting.FileSystemObject")
Set pdf = DateiName.OpenTextFile(pfad)
Do While Not pdf.AtEndOfStream
buf = pdf.ReadLine
pos = InStr(1, buf, "/Count")
If pos > 0 Then
buf = Mid(buf, pos + 7)
I = CLng(buf)
Exit Do
End If
Loop
Range("a1") = I
End Sub

Mit freundlichen Grüßen
Manfred

Hallo Manfred,
teste mal:

Option Explicit

Public Sub PDFCounter()
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        With .Filters
            If .Count > 0 Then .Delete
            Call .Add(Description:="PDF-Dateien", Extensions:="*.pdf")
        End With
        If .Show Then
            Call MsgBox(GetPageCount(.SelectedItems(1)))
        End If
    End With
End Sub

Private Function GetPageCount(ByVal pvstrFileName As String) As Long

    Dim strText As String
    Dim strLinearized As String, astrCount() As String
    Dim ialngIndex As Long
    Dim objFileSystemObject As Object, objTextFile As Object
    Dim objRegEx As Object, objMatch As Object, objItem As Object
    Dim blnFound As Boolean

    GetPageCount = -1

    Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set objTextFile = objFileSystemObject.OpenTextFile(pvstrFileName, 1, False, 0)

    Do Until objTextFile.AtEndOfStream

        strText = objTextFile.ReadLine
        strText = Replace(strText, vbLf, vbNullString)

        If Cbool(InStr(1, strText, "/Linearized")) Then

            If Len(strText) > 20 Then

                strLinearized = strText
                blnFound = True
                Exit Do

            End If
        End If

        If Cbool(InStr(1, strText, "/Count ")) Then

            Redim Preserve astrCount(ialngIndex)
            astrCount(ialngIndex) = strText
            ialngIndex = ialngIndex + 1
            blnFound = True

        End If
    Loop

    Call objTextFile.Close

    Set objTextFile = Nothing
    Set objFileSystemObject = Nothing

    If blnFound Then

        Set objRegEx = CreateObject("VBScript.RegExp")

        With objRegEx

            .MultiLine = True
            .Global = True
            .IgnoreCase = False

            If strLinearized <> vbNullString Then

                .Pattern = "\/N.?(\d+).?"

                Set objMatch = .Execute(strLinearized)

                If objMatch.Count > 0 Then _
                    GetPageCount = Clng(objMatch(0).SubMatches(0))

            Else

                If ialngIndex = 1 Then

                    .Pattern = "\/Count.?(\d+)"

                    Set objMatch = .Execute(astrCount(0))

                    If objMatch.Count = 1 Then

                        GetPageCount = Clng(objMatch(0).SubMatches(0))

                    Else

                        For Each objItem In objMatch

                            GetPageCount = WorksheetFunction.Max( _
                                GetPageCount, Clng(objItem.SubMatches(0)))

                        Next
                    End If
                Else

                    .Pattern = "\/Count.?(-?\d+)"

                    For ialngIndex = 0 To UBound(astrCount)

                        Set objMatch = .Execute(astrCount(ialngIndex))

                        GetPageCount = WorksheetFunction.Max( _
                            GetPageCount, Clng(objMatch(0).SubMatches(0)))

                    Next
                End If
            End If

        End With

        Set objMatch = Nothing
        Set objRegEx = Nothing

    End If

End Function

Gruß
Nepumuk

Forumthread: PDF Seitenanzahl feststellen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Infobox / Tutorial

PDF Seitenanzahl in Excel ermitteln

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)