'------------------------------------------------------------------------------------------------------------
'- EXIF Meta Tag reader
'- author: Chavdar Jordanov
'- based on the Exif format description at [url]http://www.ba.wakwak.com/~tsuruzoh/Computer/Digicams/exif-e.html[/url]
'------------------------------------------------------------------------------------------------------------
Option Explicit
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Type tIDF 'main structure, containg tag parameters
ID As Long
Name As String
Format As Long
Length As Long
Data As Variant
StringData As String
End Type
Public Enum enTAG 'enumerator containing the most common metatag names and their respective IDs
ImageDescription = 270
Make = 271
Model = 272
Orientation = 274
XResolution = 282
YResolution = 283
ResolutionUnit = 296
Software = 305
DateTime = 306
WhitePoint = 318
PrimaryChromaticities = 319
YCbCrCoefficients = 529
YCbCrPositioning = 531
ReferenceBlackWhite = 532
Copyright = 33432
ExifOffset = 34665
Exposuretime = 33434
FNumber = 33437
ExposureProgram = 34850
ISOSpeedRatings = 34855
ExifVersion = 36864
DateTimeOriginal = 36867
DateTimeDigitized = 36868
ComponentsConfiguration = 37121
CompressedBitsPerPixel = 37122
ShutterSpeedValue = 37377
ApertureValue = 37378
BrightnessValue = 37379
ExposureBiasValue = 37380
MaxApertureValue = 37381
SubjectDistance = 37382
MeteringMode = 37383
LightSource = 37384
Flash = 37385
FocalLength = 37386
MakerNote = 37500
UserComment = 37510
SubsecTime = 37520
SubsecTimeOriginal = 37521
SubsecTimeDigitized = 37522
FlashPixVersion = 40960
ColorSpace = 40961
ExifImageWidth = 40962
ExifImageHeight = 40963
RelatedSoundFile = 40964
ExifInteroperabilityOffset = 40965
FocalPlaneXResolution = 41486
FocalPlaneYResolution = 41487
FocalPlaneResolutionUnit = 41488
ExposureIndex = 41493
SensingMethod = 41495
FileSource = 41728
SceneType = 41729
CFAPattern = 41730
End Enum
Private Enum enFormat
unsignedByte = 1
asciiString = 2
unsignedShort = 3
unsignedLong = 4
unsignedRationale = 5
signedByte = 6
undefined = 7
signedShort = 8
signedLong = 9
signedRationale = 10
singleFloat = 11
doubleFloat = 12
End Enum
Private m_ImageFile As String 'path to the file on the disk
Private m_Intel As Boolean 'flag containing the byte alignment of the record
Private m_IniFile As String 'path to the exif.ini file containing description of the codes
Private DataLen 'array containing the byte length of each data format
Private IDName 'array containing tag names
Private IDNo 'array containing tag IDs
Private bParsed As Byte 'flag that the file has been parsed succesfuly
Private IFD() As tIDF 'array containing all metatags
'======== Interface part ==========
'-- file containing the jpeg image --
Public Property Get ImageFile() As Variant
ImageFile = m_ImageFile
End Property
Public Property Let ImageFile(ByVal vNewValue As Variant)
m_ImageFile = vNewValue
bParsed = ReadMetaInfo(m_ImageFile)
End Property
'-- returns the byte alignment order for the file --
Public Property Get IntelByteAlignment() As Boolean
IntelByteAlignment = m_Intel
End Property
'-- method, which returns the numeric and string values for a single metatag ---
Public Function MetaInfo(ByVal l_ID As enTAG, ByRef StringData As String) As Long
Dim i As Integer
If bParsed = 0 Then
For i = 1 To UBound(IFD)
If IFD(i).ID = l_ID Then
StringData = IFD(i).StringData
MetaInfo = IFD(i).Data
Exit Function
End If
Next i
StringData = "Tag " + CStr(l_ID) + " not found."
ElseIf bParsed = 1 Then
Err.Raise 10, "MetaInfo", "File is not in EXIF format."
ElseIf bParsed = 2 Then
Err.Raise 11, "MetaInfo", "Error parsing the file."
End If
End Function
'-- returns Exif tag name based on its ID --
Function GetTagName(ByVal lID As enTAG) As String
Dim i As Integer
For i = 0 To UBound(IDNo)
If lID = IDNo(i) Then
GetTagName = IDName(i)
Exit Function
End If
Next
'tag name unknown; return tag ID
GetTagName = "Tag #" + CStr(lID)
End Function
'--- Lists all metatags found in the header ---
Function ListInfo() As String
Dim i As Integer
If bParsed = 0 Then
For i = 1 To UBound(IFD)
ListInfo = ListInfo + IFD(i).Name + ": " + IFD(i).StringData + vbCrLf
Next i
ElseIf bParsed = 1 Then
ListInfo = "File is not in EXIF format."
ElseIf bParsed = 2 Then
ListInfo = "Could not open the file."
End If
End Function
'========= PARSING FUNCTIONS ==========
'-- parses the jpeg header and extracts all Exif information from it --
Private Function ReadMetaInfo(sFileName As String) As Integer
Dim sJPEG_Header As String, B() As Byte
Dim lPos As Long, Offset As Long, HeaderStart As Long
Dim i As Integer
Dim NoOfRecs As Integer
On Error GoTo ErrRead
sJPEG_Header = ReadFile(sFileName, 4096) 'may be changed to reflect the actual header size
If sJPEG_Header = "" Then
Err.Raise 2, "ReadMetaInfo", "File not found."
Else
HeaderStart = InStr(1, sJPEG_Header, "Exif" + Chr(0), vbBinaryCompare) 'start of EXIF header
If HeaderStart = 0 Then ReadMetaInfo = 1: Exit Function
HeaderStart = HeaderStart + 6 'start of data
lPos = HeaderStart
m_Intel = Mid(sJPEG_Header, lPos, 2) = "II" 'byte alignment
lPos = lPos + 4
Offset = BVal(sJPEG_Header, lPos, 4, m_Intel) 'offset to the first IFD
ReDim IFD(0)
'parse the main IFD directory and get the offset to the IFDSubDir
Offset = ParseIDF(sJPEG_Header, HeaderStart, Offset, ExifOffset)
Offset = ParseIDF(sJPEG_Header, HeaderStart, Offset, ExifInteroperabilityOffset)
End If
ExitRead:
Exit Function
ErrRead:
Dim S
S = Err.Description
Err.Raise 1, "ReadMetaInfo", S
ReadMetaInfo = 2
End Function
Reply With Quote