PDF Seitenanzahl feststellen

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread