Option Explicit
Private fn
Private maxrow As Long
Private i As Long, j As Long
Type FileHeader
ByteOrder As String * 2
VersionNum(1) As Byte
End Type
Type Entry_IFD
TagType(0 To 1) As Byte
DataType(0 To 1) As Byte
DataCount(0 To 3) As Byte
Data(0 To 3) As Byte
End Type
Sub Get_TiffProperty()
Sheet2.Range("A1").CurrentRegion.offset(1).ClearContents
Dim TargetRow As Long, EndRow As Long
EndRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For TargetRow = 2 To EndRow
Sheet1.Cells(TargetRow, 2) = GetPageNumber(Sheet1.Cells(TargetRow, 1))
Next TargetRow
With Sheet2
maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To maxrow
On Error Resume Next
.Cells(i, 3) = Application.WorksheetFunction.VLookup(.Cells(i, 2), HeaderInfoSheet.Columns("B:D"), 2, False)
.Cells(i, 4) = Application.WorksheetFunction.VLookup(.Cells(i, 2), HeaderInfoSheet.Columns("B:D"), 3, False)
On Error GoTo 0
Next i
End With
End Sub
Function GetPageNumber(TiffFileFullPath As String)
Dim header As FileHeader
fn = FreeFile
Open TiffFileFullPath For Binary As fn
Get fn, , header
Select Case header.ByteOrder
Case "II"
Close fn
GetPageNumber = GetPageNumber_Intel(TiffFileFullPath)
Case "MM"
Close fn
GetPageNumber = GetPageNumber_Motorola(TiffFileFullPath)
Case Else
Close fn
Err.Raise 9999, , "Exception ByteOrder"
End Select
End Function
Function GetPageNumber_Intel(TiffFileFullPath As String)
Dim header As FileHeader
Dim EntryCount As Integer, Tag() As Entry_IFD, NextIFD As Long
Dim pagecount As Long
fn = FreeFile
Open TiffFileFullPath For Binary As fn
Get fn, , header
If header.VersionNum(0) <> 42 Then
Close fn
Err.Raise 9999, , "This is not TiffFile"
Exit Function
End If
pagecount = 0
Do Until EOF(fn)
Get fn, , NextIFD
If NextIFD = 0 Then
Exit Do
End If
Seek #fn, NextIFD + 1
pagecount = pagecount + 1
Get fn, , EntryCount
If EntryCount > 0 Then
ReDim Tag(1 To EntryCount)
Get fn, , Tag
End If
Call Header_info("II", EntryCount, Tag(), pagecount, TiffFileFullPath)
Loop
Close fn
GetPageNumber_Intel = pagecount
End Function
Function GetPageNumber_Motorola(TiffFileFullPath As String)
Dim EntryCount_Byte(0 To 1) As Byte, EntryCount_10 As Integer, EntryCount_16 As String, Tag() As Entry_IFD
Dim NextIFD_10 As Long, NextIFD_16 As String
Dim IFDByte(3) As Byte
Dim header As FileHeader
Dim pagecount As Long
fn = FreeFile
Open TiffFileFullPath For Binary As fn
Get fn, , header
If header.VersionNum(1) <> 42 Then
Close fn
Err.Raise 9999, , "This is not TiffFile"
Exit Function
End If
pagecount = 0
Do Until EOF(fn)
Get fn, , IFDByte
NextIFD_16 = Hex(Format(IFDByte(0), "00")) & Hex(Format(IFDByte(1), "00")) & _
Hex(Format(IFDByte(2), "00")) & Hex(Format(IFDByte(3), "00"))
NextIFD_10 = Abs("&H" & NextIFD_16)
If NextIFD_10 = 0 Then
Exit Do
End If
Seek #fn, NextIFD_10 + 1
pagecount = pagecount + 1
Get fn, , EntryCount_Byte
EntryCount_16 = Hex(Format(EntryCount_Byte(0), "00")) & Hex(Format(EntryCount_Byte(1), "00"))
EntryCount_10 = Abs("&H" & EntryCount_16)
If EntryCount_10 > 0 Then
ReDim Tag(1 To EntryCount_10)
Get fn, , Tag
End If
Call Header_info("MM", EntryCount_10, Tag(), pagecount, TiffFileFullPath)
Loop
Close fn
GetPageNumber_Motorola = pagecount
End Function
Function Header_info(endianness As String, EntryCount As Integer, Tag() As Entry_IFD, pagecount As Long, TiffFileFullPath As String)
Dim curRng As Range, SearchRng As Range
Set curRng = HeaderInfoSheet.Range("A1").CurrentRegion.Resize(, 1).offset(, 1)
curRng.Resize(, 4).offset(1, 3).ClearContents
Dim TagType_16(2) As String, DataType_16(2) As String, DataCount_16(4) As String, Data_16(4) As String
Dim TagType_10 As Integer, DataType_10 As Integer, DataCount_10 As Long, Data_10 As Long
For j = 1 To EntryCount
For i = 0 To 1
Select Case CLng(Tag(j).TagType(i))
'0A～12A,0P～12Pは時刻認識され、0変換されてしまう。
'Case "0A", "1A", "2A", "3A", "4A", "5A", "6A", "7A", "8A", "9A", "10A", "11A", "12A"
Case 10, 26, 42, 58, 74, 90, 106, 122, 138, 154, 266, 282, 298
TagType_16(i + 1) = Hex(Tag(j).TagType(i))
Case Else
TagType_16(i + 1) = Format(Hex(Tag(j).TagType(i)), "00")
End Select
DataType_16(i + 1) = Format(Hex(Tag(j).DataType(i)), "00")
Next i
For i = 0 To 3
DataCount_16(i + 1) = Format(Hex(Tag(j).DataCount(i)), "00")
Data_16(i + 1) = Format(Hex(Tag(j).Data(i)), "00")
Next i
Select Case endianness
Case "II"
TagType_16(0) = TagType_16(2) & TagType_16(1)
DataType_16(0) = DataType_16(2) & DataType_16(1)
DataCount_16(0) = DataCount_16(4) & DataCount_16(3) & DataCount_16(2) & DataCount_16(1)
Data_16(0) = Data_16(4) & Data_16(3) & Data_16(2) & Data_16(1)
Case "MM"
TagType_16(0) = TagType_16(1) & TagType_16(2)
DataType_16(0) = DataType_16(1) & DataType_16(2)
DataCount_16(0) = DataCount_16(1) & DataCount_16(2) & DataCount_16(3) & DataCount_16(4)
Data_16(0) = Data_16(1) & Data_16(2) & Data_16(3) & Data_16(4)
End Select
TagType_10 = Abs("&H" & TagType_16(0))
DataType_10 = Abs("&H" & DataType_16(0))
DataCount_10 = Abs("&H" & DataCount_16(0))
Data_10 = Abs("&H" & Data_16(0))
Set SearchRng = curRng.Find(What:=TagType_10, LookAt:=xlWhole)
If Not SearchRng Is Nothing Then
If SearchRng.offset(, 3) = "" Then
SearchRng.offset(, 3) = DataType_10
SearchRng.offset(, 4) = DataCount_10
SearchRng.offset(, 5) = Data_10
SearchRng.offset(, 6) = j
End If
End If
Dim FileName As String, DirAry
DirAry = Split(TiffFileFullPath, "\")
FileName = DirAry(UBound(DirAry))
With Sheet2
maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(maxrow + 1, 1) = pagecount
.Cells(maxrow + 1, 2) = TagType_10
.Cells(maxrow + 1, 5) = DataType_10
.Cells(maxrow + 1, 6) = DataCount_10
.Cells(maxrow + 1, 7) = Data_10
.Cells(maxrow + 1, 8) = j
.Cells(maxrow + 1, 9) = FileName
End With
'Debug.Print TagType_10
'Debug.Print DataType_10
'Debug.Print DataType_10
'Debug.Print Data_10 & vbCrLf
Next j
End Function
