Is it possible to count the number of pages in a TIFF file (multi-page)? I've seen this work from someone (maybe VB) but I'm not sure if this can be converted to VBA. Output must be placed to an Excel sheet Range A1
[vba]
Attribute VB_Name = "PageCounts"
Option Explicit
Private Type LongType
lLong As Long
End Type
Private Type IntType
iInt As Integer
End Type
Private Type FourBytes
bByte1 As Byte
bByte2 As Byte
bByte3 As Byte
bByte4 As Byte
End Type
Private Type TwoBytes
bByte1 As Byte
bByte2 As Byte
End Type
Public Function PDFPageCount(sFile As String) As Long
'This function works on the assumption that each page in a PDF document is preceded by a /Type/Page
'tag. This opens the file as a byte array and counts the number of those tags. There are also
'/Type/Pages tags (used for subpages), which should not increment the count, so these are ignored.
'NOTE: This function should still work if not passed a valid pdf, but will obviously not return correctly.
Dim bFile() As Byte, bTest() As Byte, lCount As Long, lTest As Long, lFileTop As Long, lTestTop As Long
On Error GoTo ErrHand
bFile = OpenFileAsArray(sFile) 'Write the file buffer to a byte array.
bTest = StrConv("/Type/Page", vbFromUnicode) 'Write the seek string to a byte array.
lTestTop = UBound(bTest) 'Cache the UBounds to avoid multiple calls.
lFileTop = UBound(bFile)
Do Until lCount = lFileTop 'Loop through the source file.
Do Until (bFile(lCount) = bTest(0)) Or (lCount = lFileTop) 'Seek the first match for the test string.
lCount = lCount + 1 'Increment the offset counter.
Loop
For lTest = 0 To lTestTop 'Loop through the test string.
Do Until bFile(lCount) <> 32 'Skip spaces.
lCount = lCount + 1
Loop
If bFile(lCount) <> bTest(lTest) Then Exit For 'If they don't match at this offset, abort.
If lTest = lTestTop Then 'Test to see if they still match.
If bFile(lCount + 1) <> 115 Then 'Test for \Pages tag, 115 = Asc("s").
PDFPageCount = PDFPageCount + 1 'If not, increment the page count.
End If
End If
lCount = lCount + 1 'Increment the file offset.
Next lTest
Loop
ErrHand:
Err.Clear 'Not really a problem to just return. Most errors will be array bounds (last page count
'should still be fine, or file opening problems (0 return is appropriate).
End Function
Public Function TifPageCount(sFile As String) As Long
Dim bBytes() As Byte, uOffset As LongType, uTemp As FourBytes, uITemp As TwoBytes, bLEndian As Boolean
Dim iDirCount As Integer, uInt As IntType, lNext As Long
'Per .tif specification at http://partners.adobe.com/public/dev...tiff/TIFF6.pdf
'The general structure is an 8 byte header that has the starting IFD location. Each IFD has a pointer
'to the address of the next, with the last one having a 0. The first 2 IFD bytes are the number of
'12 byte entries, and these are followed by the next pointer.
On Error GoTo ErrHand
bBytes = OpenFileAsArray(sFile) 'Read the file into a byte array.
uITemp.bByte1 = bBytes(0) 'These 2 bytes are the byte order.
uITemp.bByte2 = bBytes(1)
LSet uInt = uITemp 'Convert to an integer.
If uInt.iInt = 18761 Then '18761 = "II"
bLEndian = True 'The file is little-endian byte order.
Else
If uInt.iInt <> 19789 Then 'The other valid setting is "MM", or 19789.
Exit Function 'If it isn't either, it's not a valid .tif.
End If
End If
If bLEndian Then
uITemp.bByte1 = bBytes(2) 'These 2 header bytes are the file identifier.
uITemp.bByte2 = bBytes(3)
Else 'Big-endian order.
uITemp.bByte1 = bBytes(3)
uITemp.bByte2 = bBytes(2)
End If
LSet uInt = uITemp 'Convert to an integer.
If uInt.iInt <> 42 Then Exit Function 'If this is not 42, it is not a valid .tif
If bLEndian Then
uTemp.bByte1 = bBytes(4) 'The 4-7 bytes of the header are a
uTemp.bByte2 = bBytes(5) 'pointer to the first Image File Directory.
uTemp.bByte3 = bBytes(6)
uTemp.bByte4 = bBytes(7)
Else 'Big-endian order.
uTemp.bByte1 = bBytes(7)
uTemp.bByte2 = bBytes(6)
uTemp.bByte3 = bBytes(5)
uTemp.bByte4 = bBytes(4)
End If
LSet uOffset = uTemp 'Convert to a long.
Do Until uOffset.lLong = 0 'Stop on the null pointer.
uITemp.bByte1 = bBytes(uOffset.lLong) 'Read the first 2 bytes of the IFD header for
uITemp.bByte2 = bBytes(uOffset.lLong + 1) 'the number of directory entries for this page.
LSet uInt = uITemp 'Convert to an integer.
lNext = uOffset.lLong + 2 + (12 * uInt.iInt) 'Next pointer location is the number of entries
'at 12 bytes each plus 2 for the header.
If bLEndian Then
uTemp.bByte1 = bBytes(lNext) 'Read the next pointer (4 bytes).
uTemp.bByte2 = bBytes(lNext + 1)
uTemp.bByte3 = bBytes(lNext + 2)
uTemp.bByte4 = bBytes(lNext + 3)
Else 'Big-endian order.
uTemp.bByte1 = bBytes(lNext + 3)
uTemp.bByte2 = bBytes(lNext + 2)
uTemp.bByte3 = bBytes(lNext + 1)
uTemp.bByte4 = bBytes(lNext)
End If
LSet uOffset = uTemp 'Convert to a long.
TifPageCount = TifPageCount + 1 'Increment the page count
Loop
ErrHand:
Err.Clear 'Not really a problem to just return. Most errors will be array bounds (last page count
'should still be fine, or file opening problems (0 return is appropriate).
End Function
Private Function OpenFileAsArray(sFile As String) As Byte()
'Utility function that opens a passed filename and returns it as an array of bytes. Used for the
'tif and pdf page counting functions.
Dim bTemp() As Byte, iFile As Integer, sBuffer As String
iFile = FreeFile
Open sFile For Binary As #iFile 'Open the file.
sBuffer = String$(LOF(iFile), Chr$(0)) 'Create a buffer.
Get #iFile, , sBuffer 'Write it to the buffer.
Close #iFile 'Close it.
bTemp = StrConv(sBuffer, vbFromUnicode) 'Convert to a byte array.
OpenFileAsArray = bTemp
End Function
[/vba]
Reply With Quote
