Excel VBAでTiff その1

　Excel VBAでTiffファイルのタグを読み込むプログラムを作りました。

　Tiffファイルのフォーマットは最初にコメントで書いてありますが、詳細はこちらをご覧ください。

　ソースコードは、ご自由にご利用ください。ただし、趣味のプログラムなので、保証はありません。



Option Explicit

'--------------------------------------------------
'TIFF(Tag Image File Format)ファイルの構造
'<Image File Header> + <Image File Directory (IFD)> + <画像データ>
'
'複数のIFDも可能
'ファイル内のどこに画像データを格納するかは自由
'
'--------------------------------------------------
'<Image File Header>
'ByteOrder  2bytes  Intel系なら&H49(II), Motorola系なら&H4D(MM)
'42         2bytes  固定値
'Offset     4bytes  最初のIFDへのオフセット (ファイルの先頭からデータまでのバイト数, 偶数)
'
'--------------------------------------------------
'<Image File Directory (IFD)>
'<NumberOfDirectoryEntries> + <DirectoryEntry 1> + <DirectoryEntry 2> + ... + Offset
'
'NumberOfDirectoryEntries   2bytes  DirectoryEntryの個数
'DirectoryEntry             12bytes
'Offset                     4bytes  次のIFDへのオフセット (ファイルの先頭からデータまでのバイト数, 偶数)
'
'各DirectoryEntryには､画像の幅､高さ､画像データへのオフセットなどのデータが格納されている
'次のIFDが無い場合､Offsetはゼロ
'
'--------------------------------------------------
'<DirectoryEntry>
'Tag     2bytes  データの名前
'Type    2bytes  データの型
'Count   4bytes  データの数
'Value   4bytes  データ
'
'IFD内のDirectoryEntryは、Tagの値が小さい順に格納されている
'データのサイズが4バイト未満の場合、Valueは左詰め
'データのサイズが4バイトを超える場合、Valueはデータへのオフセット (ファイルの先頭からデータまでのバイト数)
'
'--------------------------------------------------
'<画像データ>
'<Strip 1> + <Strip 2> + ...
'
'画像データは1つ以上のStripで構成されている
'各StripへのオフセットはIFD内のStripOffsetsのDirectoryEntryに格納されている
'
'--------------------------------------------------
'DirectoryEntryのTag
'
'RGB Imageで必要な必須Tag
'256 SHORT/LONG  ImageWidth                 画像の幅
'257 SHORT/LONG  ImageLength                画像の高さ
'258 SHORT       BitsPerSample              RGBなら1ピクセルに3サンプルなのでデータは8, 8, 8
'259 SHORT       Compression                非圧縮なら1
'262 SHORT       PhotometricInterpretation  RGBなら2
'273 SHORT/LONG  StripOffsets               各Stripへのオフセット
'277 SHORT       SamplesPerPixel            RGBなら3
'278 SHORT/LONG  RowsPerStrip               1つのStripに格納されている行数
'279 LONG/SHORT  StripByteCounts            1つのStripのバイトサイズ
'
'1つのStripにすべての画像データが格納されている24bit RGB画像の場合
'RowsPerStrip = ImageLength
'StripByteCounts = ImageWidth * ImageLength * 3
'
'必須ではないTag
'282 RATIONAL    XResolution                X方向の分解能
'283 RATIONAL    YResolution                Y方向の分解能
'296 SHORT       ResolutionUnit             分解能の単位
'
'274 SHORT       Orientation                画像の向き
'284 SHORT       PlanarConfiguration        データの格納方法(1 : RGBRGB..., 2 : R image, G image...)
'
'--------------------------------------------------
'DirectoryEntryのType
'
'1   Byte        1bytes
'2   ASCII       1bytes
'3   SHORT       2bytes
'4   LONG        4bytes
'
'--------------------------------------------------

Private Type DIRECTORY_ENTRY
    Tag As Integer
    Type As Integer
    Count As Long
    Value As Long
End Type

Dim ifde() As DIRECTORY_ENTRY

Public Sub test()
    Dim i As Long
    Dim filename As String
    Dim width As Long
    Dim height As Long
    Dim data() As Byte
 
    '------------------------------
    ChDir ThisWorkbook.Path
    filename = Application.GetOpenFilename
    If filename = "False" Then Exit Sub
 
    readTiff filename, data, width, height
 
    '------------------------------
    Sheet1.Cells.ClearContents
    Sheet1.Cells(1, 1) = filename
    Sheet1.Cells(2, 1) = FileLen(filename)
 
    Sheet1.Cells(4, 1) = "Tag"
    Sheet1.Cells(4, 2) = "Type"
    Sheet1.Cells(4, 3) = "TypeList"
    Sheet1.Cells(4, 4) = "TypeSize"
    Sheet1.Cells(4, 5) = "Count"
    Sheet1.Cells(4, 6) = "Value"
    Sheet1.Cells(4, 7) = "TagList"
 
    For i = LBound(ifde) To UBound(ifde)
        Sheet1.Cells(5 + i, 1) = ifde(i).Tag
        Sheet1.Cells(5 + i, 2) = ifde(i).Type
        Sheet1.Cells(5 + i, 3) = typeList(ifde(i).Type)
        Sheet1.Cells(5 + i, 4) = typeSize(ifde(i).Type)
        Sheet1.Cells(5 + i, 5) = ifde(i).Count
        Sheet1.Cells(5 + i, 6) = ifde(i).Value
        Sheet1.Cells(5 + i, 7) = tagList(ifde(i).Tag)
    Next i
 
    '------------------------------
End Sub

'Tiffファイルの読み込み
'最初のIFDだけ読み込む
Public Sub readTiff(filename As String, ByRef data() As Byte, ByRef width As Long, ByRef height As Long)
    On Error GoTo Label1
 
    Dim i As Long
    Dim buf() As Byte
    Dim offset As Long
    Dim num As Long
 
    Open filename For Binary As 1
        '------------------------------
        'Image File Header
        ReDim buf(3) As Byte
        Get 1, , buf
        If buf(0) <> &H49 Or buf(1) <> &H49 Then GoTo Label1
        If buf(2) <> 42 Or buf(3) <> 0 Then GoTo Label1
     
        Get 1, , offset
     
        '------------------------------
        'Image File Directory
        Seek 1, offset + 1
     
        ReDim buf(1) As Byte
        Get 1, , buf
        num = CLng(buf(1)) * 256 + buf(0)
 
        ReDim ifde(num - 1) As DIRECTORY_ENTRY
        Get 1, , ifde
     
        Get 1, , offset
     
        '------------------------------
    Close 1
 
    Exit Sub
Label1:
    Close 1
    MsgBox "error", vbExclamation
End Sub

Private Function typeList(tp As Integer) As String
    If tp = 1 Then
        typeList = "BYTE"
    ElseIf tp = 2 Then typeList = "ASCII"
    ElseIf tp = 3 Then typeList = "SHORT"
    ElseIf tp = 4 Then typeList = "LONG"
    ElseIf tp = 5 Then typeList = "RATIONAL"
    ElseIf tp = 6 Then typeList = "SBYTE"
    ElseIf tp = 7 Then typeList = "UNDEFINED"
    ElseIf tp = 8 Then typeList = "SSHORT"
    ElseIf tp = 9 Then typeList = "SLONG"
    ElseIf tp = 10 Then typeList = "SRATIONAL"
    ElseIf tp = 11 Then typeList = "FLOAT"
    ElseIf tp = 12 Then typeList = "DOUBLE"
    End If
End Function

Private Function typeSize(tp As Integer) As Long
    If tp = 1 Then
        typeSize = 1
    ElseIf tp = 2 Then typeSize = 1
    ElseIf tp = 3 Then typeSize = 2
    ElseIf tp = 4 Then typeSize = 4
    ElseIf tp = 5 Then typeSize = 8
    ElseIf tp = 6 Then typeSize = 1
    ElseIf tp = 7 Then typeSize = 1
    ElseIf tp = 8 Then typeSize = 2
    ElseIf tp = 9 Then typeSize = 4
    ElseIf tp = 10 Then typeSize = 8
    ElseIf tp = 11 Then typeSize = 4
    ElseIf tp = 12 Then typeSize = 8
    End If
End Function

Private Function tagList(Tag As Integer) As String
    If Tag = 254 Then
        tagList = "NewSubfileType"
    ElseIf Tag = 255 Then tagList = "SubfileType"
    ElseIf Tag = 256 Then tagList = "ImageWidth"
    ElseIf Tag = 257 Then tagList = "ImageLength"
    ElseIf Tag = 258 Then tagList = "BitsPerSample"
    ElseIf Tag = 259 Then tagList = "Compression"
    ElseIf Tag = 262 Then tagList = "PhotometricInterpretation"
    ElseIf Tag = 263 Then tagList = "Threshholding"
    ElseIf Tag = 264 Then tagList = "CellWidth"
    ElseIf Tag = 265 Then tagList = "CellLength"
    ElseIf Tag = 266 Then tagList = "FillOrder"
    ElseIf Tag = 269 Then tagList = "DocumentName"
    ElseIf Tag = 270 Then tagList = "ImageDescription"
    ElseIf Tag = 271 Then tagList = "Make"
    ElseIf Tag = 272 Then tagList = "Model"
    ElseIf Tag = 273 Then tagList = "StripOffsets"
    ElseIf Tag = 274 Then tagList = "Orientation"
    ElseIf Tag = 277 Then tagList = "SamplesPerPixel"
    ElseIf Tag = 278 Then tagList = "RowsPerStrip"
    ElseIf Tag = 279 Then tagList = "StripByteCounts"
    ElseIf Tag = 280 Then tagList = "MinSampleValue"
    ElseIf Tag = 281 Then tagList = "MaxSampleValue"
    ElseIf Tag = 282 Then tagList = "XResolution"
    ElseIf Tag = 283 Then tagList = "YResolution"
    ElseIf Tag = 284 Then tagList = "PlanarConfiguration"
    ElseIf Tag = 285 Then tagList = "PageName"
    ElseIf Tag = 286 Then tagList = "XPosition"
    ElseIf Tag = 287 Then tagList = "YPosition"
    ElseIf Tag = 288 Then tagList = "FreeOffsets"
    ElseIf Tag = 289 Then tagList = "FreeByteCounts"
    ElseIf Tag = 290 Then tagList = "GrayResponseUnit"
    ElseIf Tag = 291 Then tagList = "GrayResponseCurve"
    ElseIf Tag = 292 Then tagList = "T4Options"
    ElseIf Tag = 293 Then tagList = "T6Options"
    ElseIf Tag = 296 Then tagList = "ResolutionUnit"
    ElseIf Tag = 297 Then tagList = "PageNumber"
    ElseIf Tag = 301 Then tagList = "TransferFunction"
    ElseIf Tag = 305 Then tagList = "Software"
    ElseIf Tag = 306 Then tagList = "DateTime"
    ElseIf Tag = 315 Then tagList = "Artist"
    ElseIf Tag = 316 Then tagList = "HostComputer"
    ElseIf Tag = 317 Then tagList = "Predictor"
    ElseIf Tag = 318 Then tagList = "WhitePoint"
    ElseIf Tag = 319 Then tagList = "PrimaryChromaticities"
    ElseIf Tag = 320 Then tagList = "ColorMap"
    ElseIf Tag = 321 Then tagList = "HalftoneHints"
    ElseIf Tag = 322 Then tagList = "TileWidth"
    ElseIf Tag = 323 Then tagList = "TileLength"
    ElseIf Tag = 324 Then tagList = "TileOffsets"
    ElseIf Tag = 325 Then tagList = "TileByteCounts"
    ElseIf Tag = 332 Then tagList = "InkSet"
    ElseIf Tag = 333 Then tagList = "InkNames"
    ElseIf Tag = 334 Then tagList = "NumberOfInks"
    ElseIf Tag = 336 Then tagList = "DotRange"
    ElseIf Tag = 337 Then tagList = "TargetPrinter"
    ElseIf Tag = 338 Then tagList = "ExtraSamples"
    ElseIf Tag = 339 Then tagList = "SampleFormat"
    ElseIf Tag = 340 Then tagList = "SMinSampleValue"
    ElseIf Tag = 341 Then tagList = "SMaxSampleValue"
    ElseIf Tag = 342 Then tagList = "TransferRange"
    ElseIf Tag = 512 Then tagList = "JPEGProc"
    ElseIf Tag = 513 Then tagList = "JPEGInterchangeFormat"
    ElseIf Tag = 514 Then tagList = "JPEGInterchangeFormatLngth"
    ElseIf Tag = 515 Then tagList = "JPEGRestartInterval"
    ElseIf Tag = 517 Then tagList = "JPEGLosslessPredictors"
    ElseIf Tag = 518 Then tagList = "JPEGPointTransforms"
    ElseIf Tag = 519 Then tagList = "JPEGQTables"
    ElseIf Tag = 520 Then tagList = "JPEGDCTables"
    ElseIf Tag = 521 Then tagList = "JPEGACTables"
    ElseIf Tag = 529 Then tagList = "YCbCrCoefficients"
    ElseIf Tag = 530 Then tagList = "YCbCrSubSampling"
    ElseIf Tag = 531 Then tagList = "YCbCrPositioning"
    ElseIf Tag = 532 Then tagList = "ReferenceBlackWhite"
    ElseIf Tag = 33432 Then tagList = "Copyright"
    End If
End Function