• Home
 · 
• Graphics
 · 
• Get the X and Y extents, number of pages, resolution, and related tags, for a given list of TIFF fi

Get the X and Y extents, number of pages, resolution, and related tags, for a given list of TIFF fi

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



Rate Get the X and Y extents, number of pages, resolution, and related tags, for a given list of TIFF fi

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

  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