JPEG properties question

[Wil Moosa]

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

 

[Legacy 98055]

With:
"C:\Documents and Settings\All Users\Documents\My Pictures\Sample Pictures\Blue hills.jpg" in cell A1, this was the output in A2 to B13.

BitDepth	24
Density	1
Encoding	Baseline DCT
Extension	JFIF 1.2
filename	C:\Documents and Settings\All Users\Documents\My Pictures\Sample Pictures\Blue hills.jpg
FileSize	28521
Height	600
Precision	8
Terminated	TRUE
Width	800
XDensity	300
YDensity	300

Add a class module to your project and name it "JpegData"
Copy your code from your post, as is, into the above.

Add a standard module and paste this in:

'NOTE!
'this will over-write cells with data
Sub Example()
    'FunctionFeeder "C:\Documents and Settings\All Users\Documents\My Pictures\Sample Pictures\Blue hills.jpg"
    'or if your filename is in a range use
    FunctionFeeder Range("A1").Value
End Sub


Private Sub FunctionFeeder(filename As String)
    Dim jd As New JpegData

    If jd.ReadFile(filename) Then
        'ok
    Else
        MsgBox "Problem with file..."
        Exit Sub
    End If

    [a1].Offset(1) = "BitDepth"
    [a1].Offset(1, 1) = jd.BitDepth
    
    [a1].Offset(2) = "Density"
    [a1].Offset(2, 1) = jd.Density

    [a1].Offset(3) = "Encoding"
    [a1].Offset(3, 1) = jd.Encoding

    [a1].Offset(4) = "Extension"
    [a1].Offset(4, 1) = jd.Extension

    [a1].Offset(5) = "filename"
    [a1].Offset(5, 1) = jd.filename

    [a1].Offset(6) = "FileSize"
    [a1].Offset(6, 1) = jd.FileSize

    [a1].Offset(7) = "Height"
    [a1].Offset(7, 1) = jd.Height

    [a1].Offset(8) = "Precision"
    [a1].Offset(8, 1) = jd.Precision

    [a1].Offset(9) = "Terminated"
    [a1].Offset(9, 1) = jd.Terminated

    [a1].Offset(10) = "Width"
    [a1].Offset(10, 1) = jd.Width

    [a1].Offset(11) = "XDensity"
    [a1].Offset(11, 1) = jd.XDensity

    [a1].Offset(12) = "YDensity"
    [a1].Offset(12, 1) = jd.YDensity
    
    
End Sub

Run example. You should be able to work with it from there

 

[Ivan F Moala]

Just to ad to Tom's reply

That code you have is a Class module code.
have a look @ the original as I'm sure it was meant to be a class...... eg Property Let get etc. which is why Tom's reply was to use it as such.

 

[Legacy 98055]

Hi Ivan! What's up. Have a look at this one...

http://www.mrexcel.com/board2/viewtopic.php?t=153732&highlight=

Thanks,

Tom

 

[Wil Moosa]

Thank you all. I give it a try real soon...