Seitenanzahl sämtlicher pdf-Dateien(VBA)

Function PDFCounter(strfile As String) As Long Dim buf As String Dim fso As Object 'Scripting.FileSystemObject Dim pdf As Object 'Scripting.TextStream Dim posA As Long Dim posE As Long Dim bufLen As Long Dim temp As String, temp2 As String Dim posP As Long Dim pages As Long Set fso = CreateObject("Scripting.FileSystemObject") Set pdf = fso.OpenTextFile(strfile) Do While pages = 0 And (Not pdf.AtEndOfStream) temp = pdf.ReadLine If Left(temp, 3) = "obj" Or InStr(1, temp, " obj") > 0 Then ' Achtung es können mehrere "obj" vorkommen! buf = temp ElseIf Len(buf) > 0 Then buf = buf & temp End If If Len(buf) > 0 Then If InStr(1, temp, "endobj") > 0 Then 'Zeilenumbrüche entfernen buf = Replace(buf, vbCr, vbNullString) buf = Replace(buf, vbLf, vbNullString) 'Zeichenlänge für do-loop-Prüfung bufLen = Len(buf) posE = 1 Do 'Start finden: posA = InStr(posE, buf, "obj If posA > 0 Then posA = posA + 5 'Ende finden: posE = InStr(posA, buf, "endobj") If posE > 0 Then temp2 = Mid(buf, posA, posE - posA) 'Bedingung: /Pages und /Count muss innerhalb obj>endobj vorhanden sein If InStr(1, temp2, "/Pages") > 0 Then posP = InStr(1, temp2, "/Count") If posP > 0 Then 'Eintrag gefunden pages = Val(Mid(temp2, posP + 6)) Exit Do End If End If posE = posE + 6 Else Exit Do End If Else 'Abbruch Exit Do End If Loop While posE buf = vbNullString End If End If Loop PDFCounter = pages Debug.Print PDFCounter End Function

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Set RegExp = CreateObject("VBscript.RegExp") RegExp.Global = True RegExp.Pattern = "/Type\s*/Page[^s]" xFileNum = FreeFile Open (xFdItem & xFileName) For Binary As #xFileNum xStr = Space(LOF(xFileNum)) Get #xFileNum, , xStr Close #xFileNum Cells(I, 2) = RegExp.Execute(xStr).Count

Hallo Fabian,
teste mal (die Seitenzahl wird in Spalte B ausgegeben):

Option Explicit

Public Sub AufrufPDFCounter()
    Dim i As Long
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Cells(i, 2).Value = PDFCounter("C:\Users\Hans\Desktop\Test897\" & Cells(i, 1).Value)
    Next
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)

Seitenanzahl sämtlicher pdf-Dateien(VBA)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread