PDF-Seitenanzahl zählen

Private Sub MWReadSubFolder(ByVal sPath As String) Dim oFSO As Object Dim oFolder As Object Dim oSubFolder As Object Dim oFile As Object 'Dim von PDF-Seiten Programm Dim I As Long Dim xRg As Range Dim xStr As String Dim xFd As FileDialog Dim xFdItem As Variant Dim xFileName As String Dim xFileNum As Long Dim RegExp As Object Set oFSO = CreateObject("Scripting.FileSystemObject") Set oFolder = oFSO.GetFolder(sPath) With oSheet For Each oSubFolder In oFolder.subfolders 'Alle Dateien auflisten For Each oFile In oSubFolder.Files .Cells(lRowCounter, 1) = oSubFolder.Path .Cells(lRowCounter, 2) = oFile.Name 'von PDF-Seiten Programm Set RegExp = CreateObject("VBscript.RegExp") RegExp.Global = True RegExp.Pattern = "/Type\s*/Page[^s]" xFileNum = FreeFile Open (oSubFolder.Path & oFile.Name) For Binary As #xFileNum Ab hier werden keine Werte mehr in die xStr = Space(LOF(xFileNum)) Variablen geschrieben! Get #xFileNum, , xStr Close #xFileNum .Cells(lRowCounter, 3) = RegExp.Execute(xStr).Count lRowCounter = lRowCounter + 1 .Cells(1, 3) = lRowCounter - 3 Next oFile 'Alle Unterverzeichnisse verarbeiten (rekursiv) Call MWReadSubFolder(oSubFolder.Path) Next oSubFolder End With Set oFSO = Nothing Set oFile = Nothing Set oFolder = Nothing Set oSubFolder = Nothing End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Markus,
teste mal:


Option Explicit
Public Sub PDF_Info()
Dim strFileName As String, strFolder As String
Dim lngRow As Long
Dim astrFolders() As String
Dim ialngFolders As Long
Dim objFileDialog As FileDialog
Set objFileDialog = Application.FileDialog(fileDialogType:=msoFileDialogFolderPicker)
With objFileDialog
If .Show Then strFolder = .SelectedItems(1) & "\"
End With
Set objFileDialog = Nothing
If strFolder  vbNullString Then
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayStatusBar = True
End With
astrFolders = GetFolders(strFolder)
lngRow = 1
With Tabelle1
With .Cells(lngRow, 1).Resize(1, 2)
Call .EntireColumn.Clear
.Value = Array("Dokument", "Seiten")
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
strFileName = Dir$(astrFolders(ialngFolders) & "*.pdf")
Do Until strFileName = vbNullString
Application.StatusBar = strFileName
lngRow = lngRow + 1
.Cells(lngRow, 1).Resize(1, 2).Value = Array(strFileName, _
GetPageCount(astrFolders(ialngFolders) & strFileName))
strFileName = Dir$
Loop
Next
Call .Columns(1).AutoFit
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End If
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(Class:="Scripting.FileSystemObject")
Set objTextFile = objFileSystemObject.OpenTextFile(pvstrFileName, 1, False, 0)
Do Until objTextFile.AtEndOfStream
strText = objTextFile.ReadLine
strText = Replace(strText, vbLf, vbNullString)
If InStr(1, strText, "/Linearized") > 0 Then
If Len(strText) > 20 Then
strLinearized = strText
blnFound = True
Exit Do
End If
End If
If InStr(1, strText, "/Count ") > 0 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(Class:="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))
If objMatch.Count = 1 Then 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

Ich habe aber PDF's die sich nicht auslesen lassen.
Gruß
Nepumuk

Private Function GetFolders(ByVal pvstrPath As String) As String() Dim astrFolders() As String Dim strFolder As String, strPath As String Dim ialngIndex1 As Long, ialngIndex2 As Long ReDim Preserve astrFolders(ialngIndex1) astrFolders(ialngIndex1) = pvstrPath ialngIndex1 = 1 ialngIndex2 = 1 strPath = pvstrPath Do strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory) Do Until strFolder = vbNullString If strFolder "." And strFolder ".." Then If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then ReDim Preserve astrFolders(0 To ialngIndex1) astrFolders(ialngIndex1) = strPath & strFolder & "\" ialngIndex1 = ialngIndex1 + 1 End If End If strFolder = Dir$ Loop If ialngIndex1 = ialngIndex2 Then Exit Do strPath = astrFolders(ialngIndex2) ialngIndex2 = ialngIndex2 + 1 Loop GetFolders = astrFolders End Function

Beliebteste Forumthreads (12 Monate)

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