Wil Moosa
Well-known Member
- Joined
- Aug 11, 2002
- Messages
- 893
The following code creates functions to retrieve some information of jpeg files. I tried a few things to activate the functions but no luck so far. If the full path of the file I want information of is placed on sheet 1 in cell A1, how would the appropriate code look like?
' JPEG info version 1.11
' Written by Mike D Sutton of EDais
' Microsoft Visual Basic MVP
'' Written: 25/07/2002
' Last edited: 29/07/2003
'Version history:
'----------------
' Version 1.11 (29/07/2003):
' Minor mon-impact code changes
' Version 1.1 (31/07/2002):
' Greatly improved parse method to read all frames and work out which looks like the main image
' Version 1.0 (25/07/2002):
' Added FileName, FileSize, Width, Height, BitDepth, Precision, Terminated,
' Encoding, Extension, XDensity, YDensity and Density properties
'
' ReadFile() - Reads a JPEG file from disk and attempts to extract information from it
' DensityString() - Converts the density code to a readable string
' ClearInfo() - Clears the public information stored within the class
' FlipWord() - Flips the byte order from big to little endian (Or visa versa)
' SWordToDWord() - Extracts the unsigned value from a Signed word
'------------
Option Explicit
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Type typChunkID ' 4 bytes
cSig As Byte
cType As Byte
cSize As Integer
End Type
Private Type typSOFInfo ' 6 bytes
sofPrecision As Byte
sofHeight As Integer
sofWidth As Integer
sofComponents As Byte
End Type
Private Type typAPP0Info ' 14-bytes
appIdentity As String * 4
appNULL As Byte
appMajor As Byte
appMinor As Byte
appDensity As Byte
appXDens As Integer
appYDens As Integer
appTNWidth As Byte
appTNHeight As Byte
End Type
Private Type typFrameInfo
Width As Long
Height As Long
BitDepth As Long
Precision As Byte
Encoding As String
End Type
Dim JPGFrames() As typFrameInfo
Dim NumFrames As Long
Dim ImageFrame As Long
Dim m_FileName As String
Dim m_FileSize As Long
Dim m_Terminated As Boolean
Dim m_Extension As String
Dim m_XDensity As Integer
Dim m_YDensity As Integer
Dim m_Density As Byte
Private Const wtagSOI As Long = &HD8FF
Private Const wtagEOI As Long = &HD9FF
Private Const tagAPP0 As Byte = &HE0
Private Const tagAPP1 As Byte = &HE1
Private Const tagSOF0 As Byte = &HC0
Private Const tagSOF15 As Byte = &HCF
Private Const tagSOS As Byte = &HDA
Private Const JFIFId As String = "JFIF"
Private Const ExifId As String = "Exif"
' Public interface to member variables
Public Property Get filename() As String
filename = m_FileName
End Property
Public Property Get FileSize() As Long
FileSize = m_FileSize
End Property
Public Property Get Width() As Long
If NumFrames Then Width = JPGFrames(ImageFrame).Width
End Property
Public Property Get Height() As Long
If NumFrames Then Height = JPGFrames(ImageFrame).Height
End Property
Public Property Get BitDepth() As Long
If NumFrames Then BitDepth = JPGFrames(ImageFrame).BitDepth
End Property
Public Property Get Precision() As Byte
If NumFrames Then Precision = JPGFrames(ImageFrame).Precision
End Property
Public Property Get Encoding() As String
If NumFrames Then Encoding = JPGFrames(ImageFrame).Encoding
End Property
Public Property Get Terminated() As Boolean
Terminated = m_Terminated
End Property
Public Property Get Extension() As String
Extension = m_Extension
End Property
Public Property Get XDensity() As Integer
XDensity = m_XDensity
End Property
Public Property Get YDensity() As Integer
YDensity = m_YDensity
End Property
Public Property Get Density() As Byte
Density = m_Density
End Property
' Public methods
Public Function ReadFile(ByRef inFile As String) As Boolean
Dim FileSize As Long
Dim FNum As Integer
Dim ReadChunk As typChunkID
Dim ReadSig As Integer
Dim DoneRead As Boolean
Dim TagDesc As String
Dim SOFInfo As typSOFInfo
Dim LastPos As Long
Dim APPInfo As typAPP0Info
Dim ChunkSize As Long
Call ClearInfo
On Error Resume Next
FileSize = FileLen(inFile)
On Error GoTo 0
If (FileSize = 0) Then Exit Function
FNum = FreeFile()
Open inFile For Binary Access Read Lock Write As #FNum
Get #FNum, , ReadSig
If (ReadSig <> wtagSOI) Then
If (ReadSig = &HFFFF) Then
Do ' Offset past padding bytes
Get #FNum, , ReadChunk.cType
Loop While (ReadChunk.cType = &HFF)
If (ReadChunk.cType <> (((wtagSOI And &HFF00) \ &H100) And &HFF)) Then
Close #FNum ' SOI tag missing; most likely not a JPEG
Exit Function
End If
Else
Close #FNum ' SOI tag missing; most likely not a JPEG
Exit Function
End If
End If
' Save the current offset into the file
LastPos = Seek(FNum)
Do ' Itterate through chunks
Get #FNum, , ReadChunk
If (ReadChunk.cSig = &HFF) Then
If (ReadChunk.cType = &HFF) Then
Do ' Read past padding bytes
Get #FNum, , ReadChunk.cType
LastPos = LastPos + 1
Loop While ReadChunk.cType = &HFF
End If
ChunkSize = SWordToUWord(FlipWord(ReadChunk.cSize))
Select Case ReadChunk.cType
Case tagAPP0 ' JFIF extension
Get #FNum, , APPInfo
With APPInfo
If (.appIdentity = JFIFId) Then
m_Extension = JFIFId & " " & .appMajor & "." & .appMinor
m_XDensity = FlipWord(.appXDens)
m_YDensity = FlipWord(.appYDens)
m_Density = .appDensity
End If
End With
Case tagAPP1 ' Exif digital camera extension
Get #FNum, , APPInfo.appIdentity
If (APPInfo.appIdentity = ExifId) Then _
m_Extension = ExifId
' Notes: The Exif information is stored in a TIFF file format,
' due to overlap with the TIFF format I'm not supporting it
' here however the TIFF info class (When written) should be
' able to parse this data block.
' Dim ExifBlock() As Byte
' Seek #FNum, Seek(FNum) + 2
' ReDim ExifBlock(ReadChunk.cSize - 9) As Byte
' Get #FNum, , ExifBlock()
Case tagSOF0 To tagSOF15 ' Start of frame
Get #FNum, , SOFInfo
' Add a new frame to the list
ReDim Preserve JPGFrames(NumFrames) As typFrameInfo
With JPGFrames(NumFrames) 'Fill in this frame's information
.Width = SWordToUWord(FlipWord(SOFInfo.sofWidth))
.Height = SWordToUWord(FlipWord(SOFInfo.sofHeight))
.BitDepth = CLng(SOFInfo.sofComponents) * CLng(SOFInfo.sofPrecision)
.Precision = SOFInfo.sofPrecision
' Evaluate encoding method
Select Case (ReadChunk.cType And &HF)
Case &H0: .Encoding = "Baseline DCT"
Case &H1: .Encoding = "Extended sequential DCT, Huffman coding"
Case &H2: .Encoding = "Progressive DCT, Huffman coding"
Case &H3: .Encoding = "Lossless (Sequential), Huffman coding"
Case &H9: .Encoding = "Extended sequential DCT, arithmetic coding"
Case &HA: .Encoding = "Progressive DCT, arithmetic coding"
Case &HB: .Encoding = "Lossless (Sequential), arithmetic coding"
End Select
' Work out if this header looks like a good image
If ((.BitDepth > 0) And (.Encoding <> "") And _
((.Precision > 1) And (.Precision < 17))) Then
' Looks like a good image, is it bigger than the existing one?
' (Filter out thumnails from the main image in the file)
If ((.Width > JPGFrames(ImageFrame).Width) Or _
(.Height > JPGFrames(ImageFrame).Height)) Then _
ImageFrame = NumFrames 'This look like the main image
End If
' An unknown encoding method was encountered, put in the placeholder string
If (.Encoding = "") Then .Encoding = "Unknown encoding method"
End With
' Incrementer frame counter
NumFrames = NumFrames + 1
Case tagSOS ' Start of scan, don't bother with image data
DoneRead = True
End Select
' Seek to the next chunk
LastPos = LastPos + ChunkSize + 2
Seek FNum, LastPos
Else ' Invalid tag signature!
DoneRead = False
End If
Loop Until (DoneRead Or (LastPos >= FileSize))
' Skip to the end of the file and check to see if the EOI (End Of Image)
' tag is there - This gives us a reasonable idea if the image is broken.
Seek FNum, FileSize - 1
Get #FNum, , ReadSig
m_Terminated = ReadSig = wtagEOI
Close #FNum
' Set the file properties
m_FileName = inFile
m_FileSize = FileSize
ReadFile = True
End Function
Public Function DensityString(ByVal inMode As Byte) As String
Select Case inMode
Case 0: DensityString = "Pixels"
Case 1: DensityString = "Pixels / inch"
Case 2: DensityString = "Pixels / cm"
Case Else: DensityString = "Unknown"
End Select
End Function
' Privte methods
Private Sub ClearInfo()
m_FileName = ""
m_FileSize = 0
m_Terminated = False
m_Extension = ""
m_XDensity = 0
m_YDensity = 0
m_Density = 0
NumFrames = 0
ImageFrame = 0
ReDim JPGFrames(0) As typFrameInfo
End Sub
Private Function FlipWord(ByVal inWord As Integer) As Integer
Call RtlMoveMemory(ByVal (VarPtr(FlipWord) + 1), ByVal VarPtr(inWord), &H1)
Call RtlMoveMemory(ByVal VarPtr(FlipWord), ByVal (VarPtr(inWord) + 1), &H1)
End Function
Private Function SWordToUWord(ByVal inWord As Integer) As Long
Call RtlMoveMemory(ByVal VarPtr(SWordToUWord), ByVal VarPtr(inWord), &H2)
End Function
' JPEG info version 1.11
' Written by Mike D Sutton of EDais
' Microsoft Visual Basic MVP
'' Written: 25/07/2002
' Last edited: 29/07/2003
'Version history:
'----------------
' Version 1.11 (29/07/2003):
' Minor mon-impact code changes
' Version 1.1 (31/07/2002):
' Greatly improved parse method to read all frames and work out which looks like the main image
' Version 1.0 (25/07/2002):
' Added FileName, FileSize, Width, Height, BitDepth, Precision, Terminated,
' Encoding, Extension, XDensity, YDensity and Density properties
'
' ReadFile() - Reads a JPEG file from disk and attempts to extract information from it
' DensityString() - Converts the density code to a readable string
' ClearInfo() - Clears the public information stored within the class
' FlipWord() - Flips the byte order from big to little endian (Or visa versa)
' SWordToDWord() - Extracts the unsigned value from a Signed word
'------------
Option Explicit
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Type typChunkID ' 4 bytes
cSig As Byte
cType As Byte
cSize As Integer
End Type
Private Type typSOFInfo ' 6 bytes
sofPrecision As Byte
sofHeight As Integer
sofWidth As Integer
sofComponents As Byte
End Type
Private Type typAPP0Info ' 14-bytes
appIdentity As String * 4
appNULL As Byte
appMajor As Byte
appMinor As Byte
appDensity As Byte
appXDens As Integer
appYDens As Integer
appTNWidth As Byte
appTNHeight As Byte
End Type
Private Type typFrameInfo
Width As Long
Height As Long
BitDepth As Long
Precision As Byte
Encoding As String
End Type
Dim JPGFrames() As typFrameInfo
Dim NumFrames As Long
Dim ImageFrame As Long
Dim m_FileName As String
Dim m_FileSize As Long
Dim m_Terminated As Boolean
Dim m_Extension As String
Dim m_XDensity As Integer
Dim m_YDensity As Integer
Dim m_Density As Byte
Private Const wtagSOI As Long = &HD8FF
Private Const wtagEOI As Long = &HD9FF
Private Const tagAPP0 As Byte = &HE0
Private Const tagAPP1 As Byte = &HE1
Private Const tagSOF0 As Byte = &HC0
Private Const tagSOF15 As Byte = &HCF
Private Const tagSOS As Byte = &HDA
Private Const JFIFId As String = "JFIF"
Private Const ExifId As String = "Exif"
' Public interface to member variables
Public Property Get filename() As String
filename = m_FileName
End Property
Public Property Get FileSize() As Long
FileSize = m_FileSize
End Property
Public Property Get Width() As Long
If NumFrames Then Width = JPGFrames(ImageFrame).Width
End Property
Public Property Get Height() As Long
If NumFrames Then Height = JPGFrames(ImageFrame).Height
End Property
Public Property Get BitDepth() As Long
If NumFrames Then BitDepth = JPGFrames(ImageFrame).BitDepth
End Property
Public Property Get Precision() As Byte
If NumFrames Then Precision = JPGFrames(ImageFrame).Precision
End Property
Public Property Get Encoding() As String
If NumFrames Then Encoding = JPGFrames(ImageFrame).Encoding
End Property
Public Property Get Terminated() As Boolean
Terminated = m_Terminated
End Property
Public Property Get Extension() As String
Extension = m_Extension
End Property
Public Property Get XDensity() As Integer
XDensity = m_XDensity
End Property
Public Property Get YDensity() As Integer
YDensity = m_YDensity
End Property
Public Property Get Density() As Byte
Density = m_Density
End Property
' Public methods
Public Function ReadFile(ByRef inFile As String) As Boolean
Dim FileSize As Long
Dim FNum As Integer
Dim ReadChunk As typChunkID
Dim ReadSig As Integer
Dim DoneRead As Boolean
Dim TagDesc As String
Dim SOFInfo As typSOFInfo
Dim LastPos As Long
Dim APPInfo As typAPP0Info
Dim ChunkSize As Long
Call ClearInfo
On Error Resume Next
FileSize = FileLen(inFile)
On Error GoTo 0
If (FileSize = 0) Then Exit Function
FNum = FreeFile()
Open inFile For Binary Access Read Lock Write As #FNum
Get #FNum, , ReadSig
If (ReadSig <> wtagSOI) Then
If (ReadSig = &HFFFF) Then
Do ' Offset past padding bytes
Get #FNum, , ReadChunk.cType
Loop While (ReadChunk.cType = &HFF)
If (ReadChunk.cType <> (((wtagSOI And &HFF00) \ &H100) And &HFF)) Then
Close #FNum ' SOI tag missing; most likely not a JPEG
Exit Function
End If
Else
Close #FNum ' SOI tag missing; most likely not a JPEG
Exit Function
End If
End If
' Save the current offset into the file
LastPos = Seek(FNum)
Do ' Itterate through chunks
Get #FNum, , ReadChunk
If (ReadChunk.cSig = &HFF) Then
If (ReadChunk.cType = &HFF) Then
Do ' Read past padding bytes
Get #FNum, , ReadChunk.cType
LastPos = LastPos + 1
Loop While ReadChunk.cType = &HFF
End If
ChunkSize = SWordToUWord(FlipWord(ReadChunk.cSize))
Select Case ReadChunk.cType
Case tagAPP0 ' JFIF extension
Get #FNum, , APPInfo
With APPInfo
If (.appIdentity = JFIFId) Then
m_Extension = JFIFId & " " & .appMajor & "." & .appMinor
m_XDensity = FlipWord(.appXDens)
m_YDensity = FlipWord(.appYDens)
m_Density = .appDensity
End If
End With
Case tagAPP1 ' Exif digital camera extension
Get #FNum, , APPInfo.appIdentity
If (APPInfo.appIdentity = ExifId) Then _
m_Extension = ExifId
' Notes: The Exif information is stored in a TIFF file format,
' due to overlap with the TIFF format I'm not supporting it
' here however the TIFF info class (When written) should be
' able to parse this data block.
' Dim ExifBlock() As Byte
' Seek #FNum, Seek(FNum) + 2
' ReDim ExifBlock(ReadChunk.cSize - 9) As Byte
' Get #FNum, , ExifBlock()
Case tagSOF0 To tagSOF15 ' Start of frame
Get #FNum, , SOFInfo
' Add a new frame to the list
ReDim Preserve JPGFrames(NumFrames) As typFrameInfo
With JPGFrames(NumFrames) 'Fill in this frame's information
.Width = SWordToUWord(FlipWord(SOFInfo.sofWidth))
.Height = SWordToUWord(FlipWord(SOFInfo.sofHeight))
.BitDepth = CLng(SOFInfo.sofComponents) * CLng(SOFInfo.sofPrecision)
.Precision = SOFInfo.sofPrecision
' Evaluate encoding method
Select Case (ReadChunk.cType And &HF)
Case &H0: .Encoding = "Baseline DCT"
Case &H1: .Encoding = "Extended sequential DCT, Huffman coding"
Case &H2: .Encoding = "Progressive DCT, Huffman coding"
Case &H3: .Encoding = "Lossless (Sequential), Huffman coding"
Case &H9: .Encoding = "Extended sequential DCT, arithmetic coding"
Case &HA: .Encoding = "Progressive DCT, arithmetic coding"
Case &HB: .Encoding = "Lossless (Sequential), arithmetic coding"
End Select
' Work out if this header looks like a good image
If ((.BitDepth > 0) And (.Encoding <> "") And _
((.Precision > 1) And (.Precision < 17))) Then
' Looks like a good image, is it bigger than the existing one?
' (Filter out thumnails from the main image in the file)
If ((.Width > JPGFrames(ImageFrame).Width) Or _
(.Height > JPGFrames(ImageFrame).Height)) Then _
ImageFrame = NumFrames 'This look like the main image
End If
' An unknown encoding method was encountered, put in the placeholder string
If (.Encoding = "") Then .Encoding = "Unknown encoding method"
End With
' Incrementer frame counter
NumFrames = NumFrames + 1
Case tagSOS ' Start of scan, don't bother with image data
DoneRead = True
End Select
' Seek to the next chunk
LastPos = LastPos + ChunkSize + 2
Seek FNum, LastPos
Else ' Invalid tag signature!
DoneRead = False
End If
Loop Until (DoneRead Or (LastPos >= FileSize))
' Skip to the end of the file and check to see if the EOI (End Of Image)
' tag is there - This gives us a reasonable idea if the image is broken.
Seek FNum, FileSize - 1
Get #FNum, , ReadSig
m_Terminated = ReadSig = wtagEOI
Close #FNum
' Set the file properties
m_FileName = inFile
m_FileSize = FileSize
ReadFile = True
End Function
Public Function DensityString(ByVal inMode As Byte) As String
Select Case inMode
Case 0: DensityString = "Pixels"
Case 1: DensityString = "Pixels / inch"
Case 2: DensityString = "Pixels / cm"
Case Else: DensityString = "Unknown"
End Select
End Function
' Privte methods
Private Sub ClearInfo()
m_FileName = ""
m_FileSize = 0
m_Terminated = False
m_Extension = ""
m_XDensity = 0
m_YDensity = 0
m_Density = 0
NumFrames = 0
ImageFrame = 0
ReDim JPGFrames(0) As typFrameInfo
End Sub
Private Function FlipWord(ByVal inWord As Integer) As Integer
Call RtlMoveMemory(ByVal (VarPtr(FlipWord) + 1), ByVal VarPtr(inWord), &H1)
Call RtlMoveMemory(ByVal VarPtr(FlipWord), ByVal (VarPtr(inWord) + 1), &H1)
End Function
Private Function SWordToUWord(ByVal inWord As Integer) As Long
Call RtlMoveMemory(ByVal VarPtr(SWordToUWord), ByVal VarPtr(inWord), &H2)
End Function