VBA code to extract PDF stream from BMP (long)
James Fortune
capability of displaying special GDT (dimensioning) symbols. This led
me to create an Access form that created a PostScript file to format
the data and display the symbols. When I learned that much of the PDF
format uses stripped down PostScript I decided to roll my own PDF
reports. Using hints from Google postings I put together code that
would obtain an uncompressed PDF image stream from non-RLE encoded BMP
files so that I could include the logo on the reports. The resulting
report is about 35K. I compressed the logo using the freely available
zlib.dll and use an XObject Image filter of [/FlateDecode
/ASCIIHexDecode]. The code works on all BMP files I have tried so
far.
'-------------------------------
Public Function GetColorsFromFile(strFileName As String, ByRef
lngPixelWidth, ByRef lngPixelHeight) As String
Dim strTemp As String
Dim strCR As String
Dim strLF As String
Dim strL1 As String
Dim strL As String
Dim b As Byte
Dim lngI As Long
Dim lngJ As Long
Dim lngK As Long
Dim lngL As Long
Dim lngLenL1 As Long
Dim strR As String
Dim strG As String
Dim strB As String
Dim lngOffsetToData As Long
Dim lngPadBytes As Long
Dim lngPadNibbles As Long
Dim lngPadBits As Long
Dim lngBytesPerLine As Long
Dim lngNibblesPerLine As Long
Dim lngBitsPerLine As Long
Dim lngColorsUsed As Long
Dim lngTotalImagePixelsRead As Long
Dim strFileType As String
Dim lngBitCount As Long
Dim lngCompression As Long
Dim strHighNibble As String
Dim strLowNibble As String
Dim strBitValue As String
Dim ColorMap(256) As String
Dim strBackupImage As String
GetColorsFromFile = ""
If Len(strFileName) < 5 Then Exit Function
'Make sure the file exists
If Dir(strFileName) = "" Then Exit Function
strFileType = Right(strFileName, 3)
'For now, only allow bmp
If strFileType <> "bmp" Then Exit Function
strL = ""
strCR = Chr(13)
strLF = Chr(10)
Open strFileName For Binary As #2
strL1 = Space(LOF(2))
Get #2, 1, strL1
Close #2
'4x4 backup image
strBackupImage = "66 66 66 88 66 88 AA AA AA 88 AA CC 66 88 88 88 88
AA 88 AA CC AA CC EE 66 AA AA 88 AA CC CC 88 CC EE AA EE 88 AA CC EE
CC AA EE AA EE FF CC FF"
'Later on add jpg file type
If strFileType = "bmp" Then
'use byte 21 followed by byte 19 to compute the width in pixels of
the image
lngPixelWidth = Asc(Mid(strL1, 21, 1)) * 16 + Asc(Mid(strL1, 19, 1))
'use byte 25 followed by byte 23 to compute the height in pixels of
the image
lngPixelHeight = Asc(Mid(strL1, 25, 1)) * 16 + Asc(Mid(strL1, 23,
1))
'use byte 29 to determine biBitCount
lngBitCount = Asc(Mid(strL1, 29, 1))
''''use byte 13 followed by byte 11 to compute the offset to the
data
'''lngOffsetToData = Asc(Mid(strL1, 13, 1)) * 16 + Asc(Mid(strL1,
11, 1))
'Someone suggested that bytes 11 and 13 are not always present, so:
'Try this - use byte 49 followed by byte 47 to compute the offset to
the data
'I.e., 54 + 4 * # of RGBQUAD's (Number of Colors in Color Table)
lngColorsUsed = Asc(Mid(strL1, 49, 1)) * 16 + Asc(Mid(strL1, 47, 1))
If lngColorsUsed = 0 Then
'Adjust to maximum possible
Select Case lngBitCount
Case 1: lngColorsUsed = 2
Case 4: lngColorsUsed = 16
Case 8: lngColorsUsed = 256
End Select
End If
lngOffsetToData = 54 + 4 * lngColorsUsed
'Get the compression value, if any from byte 31
'0 = BI_RGB = no compression, 1 = BI_RLE8, 2 = BI_RLE4
lngCompression = Asc(Mid(strL1, 31, 1))
If lngCompression <> 0 Then
MsgBox ("RLE encoded bitmaps are not supported by this program.
Using backup image..")
GetColorsFromFile = strBackupImage
Exit Function
End If
Select Case lngBitCount
Case 24:
'Note: for 24 bit images, the number of colors does not matter
since no Color Table is used.
lngBytesPerLine = lngPixelWidth * 3
lngPadBytes = 4 - lngBytesPerLine + 4 * Int((lngBytesPerLine - 1)
/ 4)
'setting up this variable saves doing the modulo operation
'1 B byte, 2 G byte, 3 R byte
lngJ = 1
'This variable keeps track of which bytes are padding
'lngK keeps track of which byte we're on in the scan line. Three
bytes per pixel for image depth 24.
lngK = 1
lngLenL1 = Len(strL1)
lngTotalImagePixelsRead = 0
For lngI = lngOffsetToData + 1 To lngLenL1
'Don't forget to toss padded data since they're not part of the
RGB values
'add the string after all three values are obtained since the
order has to go from BGR to RGB
Select Case lngJ
Case 1: strB = Hex$(Asc(Mid(strL1, lngI, 1)))
If Len(strB) = 1 Then strB = "0" & strB
Case 2: strG = Hex$(Asc(Mid(strL1, lngI, 1)))
If Len(strG) = 1 Then strG = "0" & strG
Case 3: strR = Hex$(Asc(Mid(strL1, lngI, 1)))
If Len(strR) = 1 Then strR = "0" & strR
'Only add the RGB data if the values aren't a 'pad' string
If lngK <= lngBytesPerLine Then
strL = strL & " " & strR & " " & strG & " " & strB
lngTotalImagePixelsRead = lngTotalImagePixelsRead + 1
End If
End Select
lngK = lngK + 1
'As soon as we're at the last byte of the scan line, reset the
lngK value
If lngK = lngBytesPerLine + lngPadBytes + 1 Then
'starting a new scan line
lngK = 1
lngJ = 0
End If
lngJ = lngJ + 1
If lngJ = 4 Then lngJ = 1
Next lngI
'Get rid of the first space
If strL <> "" Then
strL = Right(strL, Len(strL) - 1)
End If
If lngTotalImagePixelsRead <> lngPixelWidth * lngPixelHeight Then
MsgBox ("Incorrect number of pixels read. Using backup
image..")
strL = strBackupImage
lngPixelWidth = 4
lngPixelHeight = 4
End If
Case 1:
'1 bit image - convert each bit into ' FF FF FF' or ' 00 00 00'.
lngBytesPerLine = (Int(((Int(lngPixelWidth / 8 + 0.9) - 1) / 4)) +
1) * 4
lngBitsPerLine = lngBytesPerLine * 8
lngPadBits = lngBitsPerLine - lngPixelWidth + lngBitsPerLine *
Int((lngPixelWidth - 1) / lngBitsPerLine)
'This variable keeps track of which bits are padding
'lngK keeps track of which bit we're on in the scan line. One bit
per pixel for image depth 2.
lngK = 1
lngLenL1 = Len(strL1)
lngTotalImagePixelsRead = 0
For lngI = lngOffsetToData + 1 To lngLenL1 Step lngBytesPerLine
'Don't forget to toss padded data since they're not part of the
RGB values
'add the string after all eight values are obtained
'Read in all the bytes for the given line
For lngL = 1 To lngBytesPerLine
strB = Hex$(Asc(Mid(strL1, lngI + lngL - 1, 1)))
If Len(strB) = 1 Then strB = "0" & strB
strHighNibble = Left(strB, 1)
strLowNibble = Right(strB, 1)
'Read all bits.
For lngJ = 1 To 8
'Only add the RGB data if the values aren't a 'pad' string
If lngK <= lngBitsPerLine - lngPadBits Then
Select Case lngJ
Case 1: strBitValue = Mid$(HexToBinary(strHighNibble), 1,
1)
Case 2: strBitValue = Mid$(HexToBinary(strHighNibble), 2,
1)
Case 3: strBitValue = Mid$(HexToBinary(strHighNibble), 3,
1)
Case 4: strBitValue = Mid$(HexToBinary(strHighNibble), 4,
1)
Case 5: strBitValue = Mid$(HexToBinary(strLowNibble), 1,
1)
Case 6: strBitValue = Mid$(HexToBinary(strLowNibble), 2,
1)
Case 7: strBitValue = Mid$(HexToBinary(strLowNibble), 3,
1)
Case 8: strBitValue = Mid$(HexToBinary(strLowNibble), 4,
1)
End Select
Select Case strBitValue
Case 0:
strL = strL & " 00 00 00"
Case 1:
strL = strL & " FF FF FF"
End Select
lngTotalImagePixelsRead = lngTotalImagePixelsRead + 1
End If
lngK = lngK + 1
'As soon as we're at the last bit of the scan line, reset
the lngK value
If lngK = lngBitsPerLine + 1 Then
'starting a new scan line
lngK = 1
End If
Next lngJ
Next lngL
Next lngI
'Get rid of the first space
If strL <> "" Then
strL = Right(strL, Len(strL) - 1)
End If
If lngTotalImagePixelsRead <> lngPixelWidth * lngPixelHeight Then
MsgBox ("Incorrect number of pixels read. Using backup
image..")
strL = strBackupImage
lngPixelWidth = 4
lngPixelHeight = 4
End If
Case 4:
'4 bit image
'Note: RLE Compression is only possible for 4 or 8 bit images.
'For now, assume no RLE compression is being used.
'Read in the color map, but use 1 based array instead of the
normal 0 based array
lngBytesPerLine = (Int(((Int(lngPixelWidth / 2 + 0.9) - 1) / 4)) +
1) * 4
lngNibblesPerLine = lngBytesPerLine * 2
lngPadNibbles = lngNibblesPerLine - lngPixelWidth +
lngNibblesPerLine * Int((lngPixelWidth - 1) / lngNibblesPerLine)
'setting up this variable is faster than doing the modulo
operation
'This variable keeps track of which bits are padding
'lngK keeps track of which nibble we're on in the scan line. One
nibble per pixel for image depth 4.
lngK = 1
lngLenL1 = Len(strL1)
lngTotalImagePixelsRead = 0
For lngI = 1 To lngColorsUsed
strR = Hex$(Asc(Mid(strL1, 57 + 4 * (lngI - 1), 1)))
If Len(strR) = 1 Then strR = "0" & strR
strG = Hex$(Asc(Mid(strL1, 56 + 4 * (lngI - 1), 1)))
If Len(strG) = 1 Then strG = "0" & strG
strB = Hex$(Asc(Mid(strL1, 55 + 4 * (lngI - 1), 1)))
If Len(strB) = 1 Then strB = "0" & strB
ColorMap(lngI) = " " & strR & " " & strG & " " & strB
Next lngI
'Start filling strL
For lngI = lngOffsetToData + 1 To lngLenL1 Step lngBytesPerLine
'Don't forget to toss padded data since they're not part of the
RGB values
'add the string after both values are obtained
'Read in all the bytes for the given line
For lngL = 1 To lngBytesPerLine
strB = Hex$(Asc(Mid(strL1, lngI + lngL - 1, 1)))
If Len(strB) = 1 Then strB = "0" & strB
strHighNibble = Left(strB, 1)
strLowNibble = Right(strB, 1)
'Read all nibbles.
For lngJ = 1 To 2
'Only add the RGB data if the values aren't a 'pad' string
If lngK <= lngNibblesPerLine - lngPadNibbles Then
Select Case lngJ
Case 1:
strL = strL & ColorMap(HexToDecimal(strHighNibble) + 1)
Case 2:
strL = strL & ColorMap(HexToDecimal(strLowNibble) + 1)
End Select
lngTotalImagePixelsRead = lngTotalImagePixelsRead + 1
End If
lngK = lngK + 1
'As soon as we're at the last bit of the scan line, reset
the lngK value
If lngK = lngNibblesPerLine + 1 Then
'starting a new scan line
lngK = 1
End If
Next lngJ
Next lngL
Next lngI
'Get rid of the first space
If strL <> "" Then
strL = Right(strL, Len(strL) - 1)
End If
If lngTotalImagePixelsRead <> lngPixelWidth * lngPixelHeight Then
MsgBox ("Wrong number of pixels read, using backup image..")
strL = strBackupImage
lngPixelWidth = 4
lngPixelHeight = 4
End If
Case 8:
'8 bit image
'Note: RLE Compression is only possible for 4 or 8 bit images.
'For now, assume no RLE compression is being used.
lngBytesPerLine = (Int(((Int(lngPixelWidth + 0.9) - 1) / 4)) + 1)
* 4
lngPadBytes = lngBytesPerLine - lngPixelWidth + lngBytesPerLine *
Int((lngPixelWidth - 1) / lngBytesPerLine)
'Read in the color map, but use 1 based array instead of the
normal 0 based array
lngK = 1
lngLenL1 = Len(strL1)
lngTotalImagePixelsRead = 0
For lngI = 1 To lngColorsUsed
strR = Hex$(Asc(Mid(strL1, 57 + 4 * (lngI - 1), 1)))
If Len(strR) = 1 Then strR = "0" & strR
strG = Hex$(Asc(Mid(strL1, 56 + 4 * (lngI - 1), 1)))
If Len(strG) = 1 Then strG = "0" & strG
strB = Hex$(Asc(Mid(strL1, 55 + 4 * (lngI - 1), 1)))
If Len(strB) = 1 Then strB = "0" & strB
ColorMap(lngI) = " " & strR & " " & strG & " " & strB
Next lngI
'Start filling strL
For lngI = lngOffsetToData + 1 To lngLenL1 Step lngBytesPerLine
'Don't forget to toss padded data since they're not part of the
RGB values
'add the string after both values are obtained
'Read in all the bytes for the given line
For lngL = 1 To lngBytesPerLine
strB = Hex$(Asc(Mid(strL1, lngI + lngL - 1, 1)))
If Len(strB) = 1 Then strB = "0" & strB
strHighNibble = Left(strB, 1)
strLowNibble = Right(strB, 1)
'Only add the RGB data if the values aren't a 'pad' string
If lngK <= lngBytesPerLine - lngPadBytes Then
strL = strL & ColorMap(16 * HexToDecimal(strHighNibble) +
HexToDecimal(strLowNibble) + 1)
lngTotalImagePixelsRead = lngTotalImagePixelsRead + 1
End If
lngK = lngK + 1
'As soon as we're at the last byte of the scan line, reset the
lngK value
If lngK = lngBytesPerLine + 1 Then
'starting a new scan line
lngK = 1
End If
Next lngL
Next lngI
'Get rid of the first space
If strL <> "" Then
strL = Right(strL, Len(strL) - 1)
End If
If lngTotalImagePixelsRead <> lngPixelWidth * lngPixelHeight Then
MsgBox ("Wrong number of pixels read, using backup image..")
strL = strBackupImage
lngPixelWidth = 4
lngPixelHeight = 4
End If
Case Else:
'invalid bit number was read from the file
MsgBox ("BitCount was not 1, 4, 8 or 24. Using backup image..")
strL = strBackupImage
lngPixelWidth = 4
lngPixelHeight = 4
End Select
End If
GetColorsFromFile = strL
End Function
Public Function HexToBinary(strIn As String) As String
Dim strTemp As String
Select Case strIn
Case "0": strTemp = "0000"
Case "1": strTemp = "0001"
Case "2": strTemp = "0010"
Case "3": strTemp = "0011"
Case "4": strTemp = "0100"
Case "5": strTemp = "0101"
Case "6": strTemp = "0110"
Case "7": strTemp = "0111"
Case "8": strTemp = "1000"
Case "9": strTemp = "1001"
Case "A": strTemp = "1010"
Case "B": strTemp = "1011"
Case "C": strTemp = "1100"
Case "D": strTemp = "1101"
Case "E": strTemp = "1110"
Case "F": strTemp = "1111"
Case Else:
MsgBox ("Non-hexadecimal input to Function HexToBinary.")
strTemp = "0000"
End Select
HexToBinary = strTemp
End Function
'-------------------------------
James A. Fortune