' trial ver
' Seiji Fujita rev.2 June 02, 2020 (base code: 'Haluk 19/10/2008)
' Added a file size check to prevent a zero byte file from being created if the file does not exist
' When file does not exit or filesize equal 0, return value = NOTEXIST
' When If it is impossible to count, return value = UNSUPPORTNUM
Function GetPageNum(ByVal PDF_File As String) As Long
Const NOTEXIST As Long = 0
Const UNSUPPORTNUM As Long = -99
Dim FileNum As Long
Dim strRetVal As String
Dim RegExp
Dim nFileLen As Long
Dim getpage0 As Long, getpage1 As Long, getpage2 As Long, _
getpage3 As Long, getpage4 As Long, getpage5 As Long, _
getpage6 As Long, getpage7 As Long
Application.Volatile
' return NOTEXIST when filesize equal zero or file does not exist
On Error Resume Next
nFileLen = FileLen(PDF_File)
On Error GoTo 0
If nFileLen <= 0 Then
GetPageNum = NOTEXIST
Exit Function
End If
FileNum = FreeFile
Open PDF_File For Binary As #FileNum
strRetVal = Space(LOF(FileNum))
Get #FileNum, , strRetVal
Close #FileNum
Set RegExp = CreateObject("VBscript.RegExp")
RegExp.Global = True
' getpage0 is the basics, but depending on the PDF,
' the number of this pattern differs from the number of pages
RegExp.Pattern = "/Type\s*/Page[^s]"
getpage0 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "/Resources"
getpage1 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "/ProcSet\s*\[/PDF"
getpage2 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "/Type/Catalog/Page\s*"
getpage3 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "/ExtGState"
getpage4 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "/Type/ObjStm"
getpage5 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "/Subtype/"
getpage6 = RegExp.Execute(strRetVal).Count
RegExp.Pattern = "<rdf:" ' "JFIF" ' "DeviceRGB" ' "/Ordering\(Identity" ' "Registry\(Adobe\)" ' "/BM/Normal"
getpage7 = RegExp.Execute(strRetVal).Count
If getpage0 > 0 Then
GetPageNum = getpage0
Else
If getpage5 > 0 Then
If getpage7 <= 0 Then
GetPageNum = getpage6 - getpage5 - getpage4 - 1
Else
GetPageNum = UNSUPPORTNUM ' cannot get right number; getpage6 - getpage7 - 2 * getpage1 ' not logical, adhoc
End If
Else
GetPageNum = MathMax(MathMax(getpage1, getpage2), getpage3)
' you can use below with MS Excel, insted above
' GetPageNum = Application.WorksheetFunction.Max(getpage1, getpage2, getpage3)
If GetPageNum > getpage4 Then
GetPageNum = GetPageNum - getpage4
End If
End If
End If
End Function
Function MathMax(ByVal a As Long, ByVal b As Long) As Long
If a >= b Then
MathMax = a
Else
MathMax = b
End If
End Function