by Kamishkabob (1 Submission)
Category: Graphics
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Mon 26th August 2002
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Get the X and Y extents, number of pages, resolution, and related tags, for a given list of TIFF files. Produces a listing file to summarize
API Declarations
'need InputFilename text box, for existing file that has input TIFF filenames
'need Drive1 to indicate the drive on which all the TIFF files are found
'need Dir1 to indicate the folder in which all the TIFF files are found
'need ProcessBelow button to
VBcoders
Dir1.Path = Drive1.Drive
End Sub
Private Sub Exit_Click()
End
End Sub
Private Sub ProcessBelow_Click()
Dim ImageFileHeader(0 To 7) As Byte
Dim IFDEntry(0 To 12) As Byte
Dim Position As Long
Dim Byte01 As Byte
Dim Byte02 As Byte
Dim Byte03 As Byte
Dim Byte04 As Byte
Dim Byte05 As Byte
Dim Byte06 As Byte
Dim Byte07 As Byte
Dim Byte08 As Byte
Dim FortyTwo As Integer
Dim FirstIFD_Offset As Long
Dim NextIFD_Offset As Long
Dim Number_Of_Dirs As Integer
Dim I As Integer
Dim Num As Integer
Dim TagTag As Integer
Dim TagType As Integer
Dim TagCount As Long
Dim TagValOff As Long
Dim Next_Position As Long
Dim This_Position As Long
Dim Page As Integer
Dim OutBuffer As String
Dim NextByte As Byte
Dim NextInteger As Integer
Dim NextLong As Long
Dim NextRational(1 To 2) As Long
Dim RealValue As Single
Dim FoundOne As Boolean
Const Type_Byte = 1
Const Type_Ascii = 2 'null terminated
Const Type_Short = 3 'two-byte integer
Const Type_Long = 4 'four-byte integer
Const Type_Rational = 5 'Two longs num then denom
Const Type_Sbyte = 6 'one byte twos complement
Const Type_Undefined = 7 'not defined
Const Type_Sshort = 8 'two-byte twos complement integer
Const Type_Slong = 9 'four-byte twos complement integer
Const Type_Srational = 10 'Two Slongs num then denom
Const Type_Float = 11 'real four-byte IEEE format
Const Type_Double = 12 'real eight-byte IEEE format
Dim Len_InputFilename As Integer
Dim Len_ListingFilename As Integer
Dim TifFile As Long
Dim TheFilename As String
Dim BriefFilename As String
'
'
'Open "//nodename/Myriad/Errors/218185_L.TIF" For Binary Access Read As #1
InputFilename.Text = Trim(InputFilename.Text)
Len_InputFilename = Len(InputFilename.Text)
If ((Len_InputFilename <= 0) Or (InputFilename.Text = "")) Then
Message = "Input filename cannot be blank."
MsgBox Message
InputFilename.Text = ""
Exit Sub
End If
ListingFilename.Text = Trim(ListingFilename.Text)
Len_ListingFilename = Len(ListingFilename.Text)
If ((Len_ListingFilename <= 0) Or (ListingFilename.Text = "")) Then
Message = "Listing filename cannot be blank."
MsgBox Message
ListingFilename.Text = ""
Exit Sub
End If
Dir1.Enabled = False
Drive1.Enabled = False
ProcessBelow.Enabled = False
ListingFilename.Enabled = False
InputFilename.Enabled = False
Open InputFilename.Text For Input Access Read As #3 Len = 200
Open ListingFilename.Text For Output Access Write As #2 Len = 200
Do While Not EOF(3)
Input #3, BriefFilename
BriefFilename = Trim(BriefFilename)
TheFilename = Dir1.Path & "\" & BriefFilename
Open TheFilename For Binary Access Read As #1
Form1.Caption = TheFilename
Position = 1
Get #1, Position, Byte01 'should be 73
Position = 2
Get #1, Position, Byte02 'should be 73
Position = 3
Get #1, Position, FortyTwo 'should be 42
Position = 5
Get #1, Position, FirstIFD_Offset 'offset to 1st Image File Directory
If (Byte01 <> 73) Then
Message = "Byte01 of IFD number zero does not " & _
"have value 73 (actual value " & Format(Byte01) & _
"). Exiting."
MsgBox Message
GoTo NextFile
End If
If (Byte02 <> 73) Then
Message = "Byte02 of IFD number zero does not " & _
"have value 73 (actual value " & Format(Byte02) & _
"). Exiting."
MsgBox Message
GoTo NextFile
End If
If (FortyTwo <> 42) Then
Message = "Integer at bytes 3 & 4 of IFD " & _
"number zero does not have value " & _
"42 (actual value " & Format(FortyTwo) & ". Exiting."
MsgBox Message
GoTo NextFile
End If
NextIFD_Offset = FirstIFD_Offset
Page = 0
Do
NextIFD_Offset = NextIFD_Offset + 1 'byte# starting at 1
Get #1, NextIFD_Offset, Number_Of_Dirs 'number of 12-byte directory entries, minus one
If (Number_Of_Dirs < 0) Then
Message = "Number_Of_Dirs is negative (" & Format(Number_Of_Dirs) & "). Exiting."
MsgBox Message
GoTo NextFile
End If
Next_Position = NextIFD_Offset + 2 'where next token is being read from
Page = Page + 1
OutBuffer = Trim(BriefFilename) & " Page" & Format(Page) & " "
For I = 1 To Number_Of_Dirs
FoundOne = False
Get #1, Next_Position, TagTag 'the tag
If (TagTag = 256) Then
OutBuffer = OutBuffer & "Cols"
FoundOne = True
End If
If (TagTag = 257) Then
OutBuffer = OutBuffer & "Rows"
FoundOne = True
End If
If (TagTag = 296) Then
OutBuffer = OutBuffer & "Utms"
FoundOne = True
End If
If (TagTag = 282) Then
OutBuffer = OutBuffer & "Xres"
FoundOne = True
End If
If (TagTag = 283) Then
OutBuffer = OutBuffer & "Yres"
FoundOne = True
End If
If (TagTag = 259) Then
OutBuffer = OutBuffer & "Cmpr"
FoundOne = True
End If
If (TagTag = 258) Then
OutBuffer = OutBuffer & "Bits"
FoundOne = True
End If
If (TagTag = 262) Then
OutBuffer = OutBuffer & "Zero"
FoundOne = True
End If
If (TagTag = 254) Then
OutBuffer = OutBuffer & "Subf"
FoundOne = True
End If
If (TagTag = 277) Then
OutBuffer = OutBuffer & "Spp"
FoundOne = True
End If
If (TagTag = 274) Then
OutBuffer = OutBuffer & "Ornt"
FoundOne = True
End If
Next_Position = Next_Position + 2
Get #1, Next_Position, TagType 'the tag type
Next_Position = Next_Position + 2
Get #1, Next_Position, TagCount 'the tag count
Next_Position = Next_Position + 4
If (FoundOne = True) Then
Select Case TagType
Case Type_Byte
If ((TagCount > 0) And (TagCount <= 4)) Then
For Num = 1 To TagCount
This_Position = Next_Position + Num - 1
Get #1, This_Position, NextByte
OutBuffer = OutBuffer & Format(NextByte) & " "
Next Num
End If
Case Type_Ascii
Case Type_Short
If ((TagCount > 0) And (TagCount <= 2)) Then
For Num = 1 To TagCount
If (Num = 1) Then
This_Position = Next_Position
Else
This_Position = Next_Position + 2
End If
Get #1, This_Position, NextInteger
OutBuffer = OutBuffer & Format(NextInteger) & " "
Next Num
End If
Case Type_Long
If (TagCount = 1) Then
This_Position = Next_Position
Get #1, This_Position, NextLong
OutBuffer = OutBuffer & Format(NextLong) & " "
End If
Case Type_Rational
If (TagCount = 1) Then
Get #1, Next_Position, TagValOff 'the tag value or offset
This_Position = TagValOff + 1
Get #1, This_Position, NextRational
RealValue = NextRational(1) / NextRational(2)
OutBuffer = OutBuffer & Format(RealValue) & " "
End If
Case Type_Sbyte
Case Type_Undefined
Case Type_Sshort
Case Type_Slong
Case Type_Srational
Case Type_Float
Case Type_Double
End Select
End If
Next_Position = Next_Position + 4
Next I
Get #1, Next_Position, NextIFD_Offset
Loop While NextIFD_Offset > 0
Print #2, OutBuffer
NextFile:
Close #1
Loop
Close #2
Close #3
Form1.Caption = "List page properties for TIFF files"
Dir1.Enabled = True
Drive1.Enabled = True
ProcessBelow.Enabled = True
ListingFilename.Enabled = True
InputFilename.Enabled = True
End
End Sub
No comments have been posted about Get the X and Y extents, number of pages, resolution, and related tags, for a given list of TIFF fi. Why not be the first to post a comment about Get the X and Y extents, number of pages, resolution, and related tags, for a given list of TIFF fi.