Seitenanzahl sämtlicher pdf-Dateien(VBA)
25.11.2020 14:33:40
Fabian
ich versuche mich gerade an einem Code, der dazu führen soll, dass sämtliche pdf Dateien innerhalb eines Ordners erfasst werden und ich zu den pdf Dateien die jeweilige Seitenanzahl erhalte. Hierzu verwende ich eine Function, die für sich allein genommen bereits funktioniert. Hierbei muss allerdings der Pfad jeder einzelnen pdf-Datei manuell eingetragen werden. Die jeweiligen Pfade habe ich mittels makro (ist nicht Bestandteil des folgenden Codes, da irrelevant) erzeugt und in ein Tabellenblatt eintragen lassen.
Wenn ich nun die Function aufrufe und dabei als Argument die Pfade aus dem Tabellenblatt verwende, funktioniert dies leider nicht wie gewünscht. Kann mir Jemand bei dem Problem weiterhelfen?
Der Code dazu sieht wie folgt aus:
Option Explicit
Sub AufrufPDFCounter()
Dim PfaPDF(1000) As String
Dim i As Integer
Range("A2").Select
For i = 2 To 4
Cells(i, 1).Select
PfaPDF(i) = Chr(34) & "C:\Users\Hans\Desktop\Test897" & Selection.Value & Chr(34)
PDFCounter (PfaPDF(i))
Debug.Print PfaPDF(i) ' um die Ausgabe zu testen
Next
Range("A1").Select
End Sub
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
Anzeige