Q&A
コードは回答欄ではなく、質問欄に書いてください。
質問は編集できます
前提・実現したいこと
現在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
LZW解凍の学習目的でしょうか？それとも単にTIFFファイルを開ければよいだけでしょうか？
y_waiwaiさん
>コードは回答欄ではなく、質問欄に書いてください。
>質問は編集できます
文字数オーバの為回答欄に記載となり、失礼しました。
radianさん
>LZW解凍の学習目的でしょうか？それとも単にTIFFファイルを開ければよいだけでしょうか？
目的としてはLZW解凍の学習目的のほうが近いです。
回答4件
0
ベストアンサー
すべてのタグを読んでいますか?
具体的には0x013Dを見逃しているように見えます。
投稿2020/09/15 04:27
総合スコア3047
ご指摘の通り0x013D(Differencing Predictor)は2(水平差分)が設定されていました。
てっきり256色やグレースケールで使われると誤解していました。
処理を追加したところ正常な値が取得できました
ありがとうございます。
ソースは別に回答欄に記載しておきます。
0
指摘を受け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
総合スコア2506
0
※文字数制限の為こちらに記載しています。(ソースコード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総合スコア2506
0
※文字数制限の為こちらに記載しています。(ソースコード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
投稿2020/09/14 23:20
編集2020/09/15 03:16総合スコア2506
あなたの回答
tips
プレビュー
