TIFF形式の画像ファイルでのLZW圧縮(解凍)について

前提・実現したいこと

現在VBAにてTIFF形式の画像ファイルのデータを取得しようとしています。
Windows付属のペイントで横にRGB(0,0,0)RGB(237,28,36)RGB(63,72,204)と並んだ
3ピクセルのTIFF画像を作成しタグ情報を取得する所まではできました。

タグ情報を調べると、リトルエンディアン・LZW圧縮・RGBダイレクトカラーという事が判り
ストリップのバイト配列に対して作成したファンクションでLZW解凍を行ったのですが
思った結果になりませんでした。

どうして値が違うのか原因がわからず困っています。

発生している問題・エラーメッセージ

TIFF形式の画像ファイルの該当ストリップデータを抜き出すと
Array(128, 0, 32, 79, 247, 104, 112, 72, 0, 41, 11, 21, 0, 8, 8)
となります。

正常にLZW解凍されれば
Array(0, 0, 0, 255, 237, 28, 36, 255, 63, 72, 204, 255)
となると思われます。

これを自作のコードでLZW解凍すると
Array(0, 0, 0, 255, 237, 28, 36, 0, 82, 44, 168, 0)
となってしまいます。

試したこと

ペイントとGIMPでLZW圧縮をしたtiffを作成しましたが
ストリップデータに関しては同じ
Array(128, 0, 32, 79, 247, 104, 112, 72, 0, 41, 11, 21, 0, 8, 8)
となりました。

GIMPでtiffの非圧縮を作成調査したところ
Array(0, 0, 0, 255, 237, 28, 36, 255, 63, 72, 204, 255)
と想定されたストリップデータが格納されていました。

またLZW圧縮に関しては4サイトのロジックをVBAに変換して試しましたが
上記ロジックと同じ
Array(0, 0, 0, 255, 237, 28, 36, 0, 82, 44, 168, 0)
となりました

該当のソースコード

※文字数制限の為、回答欄に分割記載しています。

補足情報（FW/ツールのバージョンなど）

Access2013 VBA

y_waiwai

2020/09/15 00:05

コードは回答欄ではなく、質問欄に書いてください。質問は編集できます

退会済みユーザー

2020/09/15 00:24 編集

LZW解凍の学習目的でしょうか？それとも単にTIFFファイルを開ければよいだけでしょうか？

kuma_kuma_

2020/09/15 02:58

y_waiwaiさん >コードは回答欄ではなく、質問欄に書いてください。 >質問は編集できます文字数オーバの為回答欄に記載となり、失礼しました。

kuma_kuma_

2020/09/15 03:04

radianさん >LZW解凍の学習目的でしょうか？それとも単にTIFFファイルを開ければよいだけでしょうか？目的としてはLZW解凍の学習目的のほうが近いです。

行動規範の内容に同意します

回答4件

ベストアンサー

すべてのタグを読んでいますか?
具体的には0x013Dを見逃しているように見えます。

投稿2020/09/15 04:27

ikadzuchi

総合スコア3047

kuma_kuma_

2020/09/15 13:05

ご指摘の通り0x013D(Differencing Predictor)は2(水平差分)が設定されていました。てっきり256色やグレースケールで使われると誤解していました。処理を追加したところ正常な値が取得できましたありがとうございます。

kuma_kuma_

2020/09/15 13:06 編集

ソースは別に回答欄に記載しておきます。

行動規範の内容に同意します

指摘を受けDifferencing Predictor(差分予測復号)を追加したバージョンです。
正しい値に復号できました

該当のソースコード

vba
1Function testLZW()
2    
3    Dim varData             As Variant
4    Dim lngIndex            As Long
5    Dim bytCompressed()     As Byte '圧縮前データ
6    Dim bytDecompressed()   As Byte '圧縮後データ
7    
8    '***** 圧縮データ
9    Debug.Print "LZW圧縮データ"
10    varData = Array(128, 0, 32, 79, 247, 104, 112, 72, 0, 41, 11, 21, 0, 8, 8)
11    ReDim bytCompressed(0 To UBound(varData))
12    For lngIndex = 0 To UBound(varData)
13        bytCompressed(lngIndex) = varData(lngIndex)
14        Debug.Print varData(lngIndex) & ", ";
15    Next lngIndex
16    Debug.Print
17    
18    '----- 解凍
19    Erase bytDecompressed()
20    Call LZWDecompressed(bytCompressed(), bytDecompressed())
21
22    '----- Differencing Predictor(差分予測復号)
23    Dim lngBef As Long
24    Dim lngAft As Long
25    Dim strHex As String
26    Dim intGetPoint As Integer
27    Dim intSetPoint As Integer
28    
29    '***** 本来「行列」で取得しなければならないが、1行3列の為割愛する
30    For lngIndex = 4 To UBound(bytDecompressed) Step 4
31        '----- RGBバイトをLong型へ結合(前)
32        strHex = "&h"
33        strHex = strHex & Right("0" & Hex(bytDecompressed(lngIndex - 1)), 2)
34        strHex = strHex & Right("0" & Hex(bytDecompressed(lngIndex - 2)), 2)
35        strHex = strHex & Right("0" & Hex(bytDecompressed(lngIndex - 3)), 2)
36        strHex = strHex & Right("0" & Hex(bytDecompressed(lngIndex - 4)), 2)
37        lngBef = CLng(strHex)
38        
39        '----- RGBバイトをLong型へ結合(後)
40        strHex = "&h"
41        strHex = strHex & Right("0" & Hex(bytDecompressed(lngIndex + 3)), 2)
42        strHex = strHex & Right("0" & Hex(bytDecompressed(lngIndex + 2)), 2)
43        strHex = strHex & Right("0" & Hex(bytDecompressed(lngIndex + 1)), 2)
44        strHex = strHex & Right("0" & Hex(bytDecompressed(lngIndex + 0)), 2)
45        lngAft = CLng(strHex)
46
47        '----- 差分からRGBへ変換
48        lngAft = lngBef + lngAft
49        
50        '----- Long型をRGBバイトへ変換し設定
51        strHex = Right("00000000" & Hex(lngAft), 8)
52        intSetPoint = 3
53        For intGetPoint = 1 To Len(strHex) Step 2
54            bytDecompressed(lngIndex + intSetPoint) = CByte("&h" & Mid(strHex, intGetPoint, 2))
55            intSetPoint = intSetPoint - 1
56        Next intGetPoint
57        
58    Next lngIndex
59    
60    '***** 解凍データ
61    Debug.Print "解凍データ"
62    For lngIndex = 0 To UBound(bytDecompressed)
63        Debug.Print bytDecompressed(lngIndex) & ", ";
64    Next lngIndex
65    Debug.Print
66
67End Function

投稿2020/09/15 13:13

kuma_kuma_

総合スコア2506

※文字数制限の為こちらに記載しています。(ソースコード1)

該当のソースコード

VBA
1Private Sub initDecompDictionary(objDictionary As Object, bytBitRange As Byte, lngEntryNoMax As Long, CLEAR_CODE As String, END_CODE As String, bytCurrentBitSize As Byte)
2'-------------------------------------------------------------------------------
3'   initDecompDictionary
4'   説明
5'       LZW解凍用辞書の設定
6'   パラメータ
7'       objDictionary       : 解凍用辞書
8'       bytBitRange         : 変換前の値を表すのに必要な最大ビット数
9'       lngEntryNoMax       : 辞書登録Noの最大値
10'       CLEAR_CODE          : クリアコード
11'       END_CODE            : エンドコード
12'       bytCurrentBitSize   : 辞書登録Noの最大値を表すのに必要なビット数
13'-------------------------------------------------------------------------------
14    
15    Dim lngEntryNo                      As Long         ' 辞書登録No
16    
17On Error GoTo initDecompDictionary_Err:
18    
19    '----- 辞書の生成
20    Set objDictionary = CreateObject("Scripting.Dictionary")
21    
22    '----- 辞書の初期化
23    lngEntryNoMax = 2 ^ bytBitRange - 1
24    
25    '----- 辞書の設定
26    For lngEntryNo = 0 To lngEntryNoMax
27        Call objDictionary.Add(LongToLEBits(lngEntryNo, 12), LongToLEBits(lngEntryNo, 12))
28    Next lngEntryNo
29
30    '----- クリアコードの設定
31    lngEntryNoMax = lngEntryNoMax + 1
32    CLEAR_CODE = LongToLEBits(lngEntryNoMax, 12)
33    Call objDictionary.Add("CLEAR_CODE", "CLEAR_CODE")
34    
35    '----- エンドコードの設定
36    lngEntryNoMax = lngEntryNoMax + 1
37    END_CODE = LongToLEBits(lngEntryNoMax, 12)
38    Call objDictionary.Add("END_CODE", "END_CODE")
39
40    '----- 辞書登録Noの最大値を表すのに必要なビット数取得
41    bytCurrentBitSize = getBitsLength(lngEntryNoMax)
42
43initDecompDictionary_End:
44On Error Resume Next
45Exit Sub
46
47'----- エラー処理
48initDecompDictionary_Err:
49    Call Err.Raise(Err, "initDecompDictionary", Error)
50Resume initDecompDictionary_End:
51End Sub

VBA
1Public Sub LZWDecompressed(ByRef bytCompressed() As Byte, ByRef bytDecompressed() As Byte)
2'-------------------------------------------------------------------------------
3'   LZWDecompressed
4'   説明
5'       LZW解凍
6'       https://www.adobe.io/content/dam/udp/en/open/standards/tiff/TIFF6.pdf 61ページ
7'   パラメータ
8'       bytCompressed   : LZW圧縮バイト配列
9'   戻り値
10'       bytDecompressed : 解凍バイト配列
11'-------------------------------------------------------------------------------
12    
13    Dim lngGetPoint                     As Long         ' 取得位置
14    Dim lngSetPoint                     As Long         ' 設定位置
15    Dim lngPoint                        As Long         ' 位置
16    Dim objDictionary                   As Object       ' 辞書
17    Dim CLEAR_CODE                      As String       ' クリアコード
18    Dim END_CODE                        As String       ' 終了コード
19    Dim strCompressedBit                As String       ' 圧縮ビット文字列
20    Dim strDecompressedBit              As String       ' 解凍ビット文字列
21    Dim bytBitRange                     As Byte         ' 変換前の値を表すのに必要な最大ビット数
22    Dim bytCurrentBitSize               As Byte         ' 辞書登録Noの最大値を表すのに必要なビット数
23    Dim lngEntryNoMax                   As Long         ' 辞書登録Noの最大値
24    Dim strBitStream()                  As String       ' 圧縮後ビット文字列(辞書登録No毎)
25    Dim strBit                          As String       ' 2進数文字列
26    Dim strPrefixBit                    As String       ' 前方2進数
27    Dim strEntryBit                     As String       ' 辞書登録2進数
28    Dim strEntryKey                     As String       ' 辞書登録キー
29    
30On Error GoTo LZWDecompressed_Err:
31    
32    '----- 値の初期化
33    bytBitRange = 8
34    strCompressedBit = ""
35    ReDim bytDecompressed(0 To UBound(bytCompressed) * 2)      '最大は仮設定
36    lngSetPoint = -1
37    
38    '----- ビット文字列へ変換
39    ReDim strBitStream(0 To UBound(bytCompressed))
40    For lngGetPoint = 0 To UBound(bytCompressed)
41        strBitStream(lngGetPoint) = LongToLEBits(CLng(bytCompressed(lngGetPoint)), 8)
42    Next lngGetPoint
43    strCompressedBit = Join(strBitStream, "")
44    Erase strBitStream
45    
46    '----- 辞書の初期化
47    Call initDecompDictionary(objDictionary, bytBitRange, lngEntryNoMax, CLEAR_CODE, END_CODE, bytCurrentBitSize)
48    
49    lngGetPoint = 1
50    lngSetPoint = -1
51    Do Until lngGetPoint > Len(strCompressedBit)
52        
53        '----- ビットの取得
54        strBit = Right("0000000000000" & Mid(strCompressedBit, lngGetPoint, bytCurrentBitSize), 12)
55        lngGetPoint = lngGetPoint + bytCurrentBitSize
56
57        Select Case strBit
58            Case CLEAR_CODE
59                '----- 辞書の初期化
60                Call initDecompDictionary(objDictionary, bytBitRange, lngEntryNoMax, CLEAR_CODE, END_CODE, bytCurrentBitSize)
61                strEntryBit = ""
62            
63            Case END_CODE
64                '----- 変換終了
65                Exit Do
66
67            Case Else
68                If objDictionary.Exists(strBit) Then
69                    '----- 辞書に登録がある場合
70                    strEntryBit = objDictionary.Item(strBit)
71                
72                Else
73                    '----- 辞書に登録が無い場合
74                    strEntryBit = strPrefixBit & Left(strPrefixBit, 12)
75                
76                End If
77
78        End Select
79
80        '----- 解凍値の挿入
81        For lngPoint = 1 To Len(strEntryBit) Step 12
82            lngSetPoint = lngSetPoint + 1
83            bytDecompressed(lngSetPoint) = LEBitsToLong(Mid(strEntryBit, lngPoint, 12))
84        Next lngPoint
85        strEntryBit = ""
86
87        '----- 辞書の登録
88        strEntryKey = strPrefixBit & Left(strBit, 12)
89        If Len(strEntryKey) > 0 Then
90            If Not objDictionary.Exists(strEntryKey) Then
91                lngEntryNoMax = lngEntryNoMax + 1
92                Call objDictionary.Add(strEntryKey, LongToLEBits(lngEntryNoMax, 12))
93                bytCurrentBitSize = getBitsLength(lngEntryNoMax)
94            End If
95        End If
96
97        strPrefixBit = strBit
98    Loop
99    
100    ReDim Preserve bytDecompressed(0 To lngSetPoint)
101
102LZWDecompressed_End:
103On Error Resume Next
104Exit Sub
105
106'----- エラー処理
107LZWDecompressed_Err:
108    Call Err.Raise(Err, "LZWDecompressed", Error)
109Resume LZWDecompressed_End:
110End Sub

vba
1Function testLZW()
2    
3    Dim varData             As Variant
4    Dim lngIndex            As Long
5    Dim bytCompressed()     As Byte '圧縮前データ
6    Dim bytDecompressed()   As Byte '圧縮後データ
7    
8    '***** 圧縮データ
9    Debug.Print "LZW圧縮データ"
10    varData = Array(128, 0, 32, 79, 247, 104, 112, 72, 0, 41, 11, 21, 0, 8, 8)
11    ReDim bytCompressed(0 To UBound(varData))
12    For lngIndex = 0 To UBound(varData)
13        bytCompressed(lngIndex) = varData(lngIndex)
14        Debug.Print varData(lngIndex) & ", ";
15    Next lngIndex
16    Debug.Print
17
18    '***** 解凍
19    Erase bytDecompressed()
20    Call LZWDecompressed(bytCompressed(), bytDecompressed())
21
22    '***** 解凍データ
23    Debug.Print "解凍データ"
24    For lngIndex = 0 To UBound(bytDecompressed)
25        Debug.Print bytDecompressed(lngIndex) & ", ";
26    Next lngIndex
27    Debug.Print
28
29End Function

投稿2020/09/14 23:22

編集2020/09/15 03:15

kuma_kuma_

総合スコア2506

※文字数制限の為こちらに記載しています。(ソースコード2)

該当のソースコード

VBA
1Public Function getBitsLength(ByVal val As Long) As Byte
2'-------------------------------------------------------------------------------
3'   getBitsLength
4'   説明
5'       ビット長の取得(3bitから12bit)
6'   パラメータ
7'       val             : 値
8'   戻り値
9'       3bitから12bit
10'-------------------------------------------------------------------------------
11    
12On Error GoTo getBitsLength_Err:
13    
14    Select Case val
15        Case 8 To 4095
16            getBitsLength = CByte(Int(Log(val) / Log(2))) + 1
17        Case 0 To 7
18            getBitsLength = 3
19        Case Is >= 4096
20            getBitsLength = 12
21        Case Else
22            getBitsLength = 0
23    End Select
24
25getBitsLength_End:
26On Error Resume Next
27Exit Function
28
29'----- エラー処理
30getBitsLength_Err:
31    Call Err.Raise(Err, "getBitsLength", Error)
32Resume getBitsLength_End:
33End Function

VBA
1Private Function LEBitsToHex(val As String, Optional Digits As Byte = 0) As String
2'-------------------------------------------------------------------------------
3'   LEBitsToHex
4'   説明
5'       リトルエンディアンの2進数文字列を16進数文字列へ変換
6'   パラメータ
7'       val             : 値
8'       Digits          : 桁数
9'   戻り値
10'       16進数文字列
11'-------------------------------------------------------------------------------
12    
13    Static objLEBitToHex    As Object   '2進数→16進数変換
14    Static strZeros()       As String   '0埋め文字列
15    Dim strHexs             As String
16    Dim lngPoint            As Long
17    
18On Error GoTo LEBitsToHex_Err:
19    
20    If objLEBitToHex Is Nothing Then
21        '----- 2進数→16進数変換
22        Set objLEBitToHex = CreateObject("Scripting.Dictionary")
23        Call objLEBitToHex.Add("0000", "0")
24        Call objLEBitToHex.Add("0001", "1")
25        Call objLEBitToHex.Add("0010", "2")
26        Call objLEBitToHex.Add("0011", "3")
27        Call objLEBitToHex.Add("0100", "4")
28        Call objLEBitToHex.Add("0101", "5")
29        Call objLEBitToHex.Add("0110", "6")
30        Call objLEBitToHex.Add("0111", "7")
31        Call objLEBitToHex.Add("1000", "8")
32        Call objLEBitToHex.Add("1001", "9")
33        Call objLEBitToHex.Add("1010", "A")
34        Call objLEBitToHex.Add("1011", "B")
35        Call objLEBitToHex.Add("1100", "C")
36        Call objLEBitToHex.Add("1101", "D")
37        Call objLEBitToHex.Add("1110", "E")
38        Call objLEBitToHex.Add("1111", "F")
39    
40        '----- 0埋め文字列
41        Dim lngIndex            As Long
42        ReDim strZeros(0 To 16)
43        For lngIndex = 1 To 15
44            strZeros(lngIndex) = String(lngIndex, "0")
45        Next lngIndex
46    
47    End If
48    
49    '----- 2進数→16進数変換
50    For lngPoint = Len(val) To 3 Step -4
51        strHexs = objLEBitToHex.Item(Mid(val, lngPoint - 3, 4)) & strHexs
52    Next lngPoint
53    
54    If Digits = 0 Then
55        LEBitsToHex = strHexs
56    Else
57        '----- 桁揃え
58        Select Case Len(strHexs)
59            Case Is < Digits
60                LEBitsToHex = strHexs & strZeros(Digits - Len(strHexs))
61            Case Is > Digits
62                LEBitsToHex = Left(strHexs, Digits)
63            Case Digits
64                LEBitsToHex = strHexs
65        End Select
66    End If
67
68LEBitsToHex_End:
69On Error Resume Next
70Exit Function
71
72'----- エラー処理
73LEBitsToHex_Err:
74    Call Err.Raise(Err, "LEBitsToHex", Error)
75Resume LEBitsToHex_End:
76End Function

VBA
1Private Function LEBitsToLong(val As String) As Long
2'-------------------------------------------------------------------------------
3'   LEBitsToLong
4'   説明
5'       リトルエンディアンの2進数文字列をLong型へ変換
6'   パラメータ
7'       val             : 値
8'   戻り値
9'       Long型値
10'-------------------------------------------------------------------------------
11    
12On Error GoTo LEBitsToLong_Err:
13    
14    LEBitsToLong = CLng("&h" & LEBitsToHex(val))
15
16LEBitsToLong_End:
17On Error Resume Next
18Exit Function
19
20'----- エラー処理
21LEBitsToLong_Err:
22    Call Err.Raise(Err, "LEBitsToLong", Error)
23Resume LEBitsToLong_End:
24End Function

VBA
1Function LongToLEBits(val As Long, Digits As Byte) As String
2'-------------------------------------------------------------------------------
3'   LongToLEBits
4'   説明
5'       Long型からリトルエンディアンの2進数文字列へ変換
6'   パラメータ
7'       val             : 値
8'       Digits          : 桁数
9'   戻り値
10'       2進数文字列
11'-------------------------------------------------------------------------------
12    
13    Static objHexToLEBit    As Object   '16進数→2進数変換
14    Static strZeros()       As String   '0埋め文字列
15    Dim strHexs             As String
16    Dim strBits             As String
17    Dim lngPoint            As Long
18    
19On Error GoTo LongToLEBits_Err:
20    
21    If objHexToLEBit Is Nothing Then
22        '----- 16進数→2進数変換
23        Set objHexToLEBit = CreateObject("Scripting.Dictionary")
24        Call objHexToLEBit.Add("0", "0000")
25        Call objHexToLEBit.Add("1", "0001")
26        Call objHexToLEBit.Add("2", "0010")
27        Call objHexToLEBit.Add("3", "0011")
28        Call objHexToLEBit.Add("4", "0100")
29        Call objHexToLEBit.Add("5", "0101")
30        Call objHexToLEBit.Add("6", "0110")
31        Call objHexToLEBit.Add("7", "0111")
32        Call objHexToLEBit.Add("8", "1000")
33        Call objHexToLEBit.Add("9", "1001")
34        Call objHexToLEBit.Add("A", "1010")
35        Call objHexToLEBit.Add("B", "1011")
36        Call objHexToLEBit.Add("C", "1100")
37        Call objHexToLEBit.Add("D", "1101")
38        Call objHexToLEBit.Add("E", "1110")
39        Call objHexToLEBit.Add("F", "1111")
40    
41        '----- 0埋め文字列
42        Dim lngIndex            As Long
43        ReDim strZeros(0 To 32)
44        For lngIndex = 1 To 31
45            strZeros(lngIndex) = String(lngIndex, "0")
46        Next lngIndex
47    End If
48
49    strHexs = Hex(val)
50    For lngPoint = 1 To Len(strHexs)
51        strBits = strBits & objHexToLEBit.Item(Mid(strHexs, lngPoint, 1))
52    Next lngPoint
53    
54    Select Case Len(strBits)
55        Case Is < Digits
56            LongToLEBits = strZeros(Digits - Len(strBits)) & strBits
57        Case Is > Digits
58            LongToLEBits = Right(strBits, Digits)
59        Case Digits
60            LongToLEBits = strBits
61    End Select
62
63LongToLEBits_End:
64On Error Resume Next
65Exit Function
66
67'----- エラー処理
68LongToLEBits_Err:
69    Call Err.Raise(Err, "LongToLEBits", Error)
70Resume LongToLEBits_End:
71End Function