読み人知らず: 9月 2018

2018年9月10日月曜日

Excel VBAでTiff その2

　前回のプログラムを少しいじって、Tiffファイルを読み書きできるようにしました。ただし、面倒なのでRGBだけとか制限をつけていますが。
　作ってみて思うのですが、やっぱりBitmapのフォーマットが単純でいいです。。。

　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

Private ifde() As DIRECTORY_ENTRY

Public Sub test()
Dim i As Long
Dim j As Long
Dim pos As Long
Dim filename As String
Dim width As Long
Dim height As Long
Dim data() As Byte

'------------------------------
width = 128
height = 128
ReDim data(width * height * 3 - 1) As Byte

For i = 0 To height - 1
For j = 0 To width - 1
pos = (i * width + j) * 3
data(pos + 0) = 255 * j / width
data(pos + 1) = 255 * i / height
data(pos + 2) = 0
Next j
Next i

'------------------------------
filename = ThisWorkbook.Path + "\temp.tif"
writeTiff filename, data, width, height

'------------------------------
readTiff filename, data, width, height

'------------------------------
End Sub

'Tiffファイルの保存
'Intel系, IFDは1個, Stripは1個, 24bitフルカラーのみ対応
Public Sub writeTiff(filename As String, data() As Byte, width As Long, height As Long)
Dim buf() As Byte
Dim offset As Long

Open filename For Binary As 1
'------------------------------
'Image File Header
ReDim buf(3) As Byte
buf(0) = &H49
buf(1) = &H49
buf(2) = 42
buf(3) = 0
Put 1, , buf

offset = width * height * 3 + 8
Put 1, , offset

'------------------------------
'画像データ
Put 1, , data

'------------------------------
'Image File Directory
ReDim buf(1) As Byte
buf(0) = 11
buf(1) = 0
Put 1, , buf

ReDim ifde(10) As DIRECTORY_ENTRY
ifde(0).Tag = 256: ifde(0).Type = 3: ifde(0).Count = 1: ifde(0).Value = width
ifde(1).Tag = 257: ifde(1).Type = 3: ifde(1).Count = 1: ifde(1).Value = height
ifde(2).Tag = 258: ifde(2).Type = 3: ifde(2).Count = 3: ifde(2).Value = offset + 138
ifde(3).Tag = 259: ifde(3).Type = 3: ifde(3).Count = 1: ifde(3).Value = 1
ifde(4).Tag = 262: ifde(4).Type = 3: ifde(4).Count = 1: ifde(4).Value = 2
ifde(5).Tag = 273: ifde(5).Type = 4: ifde(5).Count = 1: ifde(5).Value = 8
ifde(6).Tag = 274: ifde(6).Type = 3: ifde(6).Count = 1: ifde(6).Value = 1
ifde(7).Tag = 277: ifde(7).Type = 3: ifde(7).Count = 1: ifde(7).Value = 3
ifde(8).Tag = 278: ifde(8).Type = 3: ifde(8).Count = 1: ifde(8).Value = height
ifde(9).Tag = 279: ifde(9).Type = 4: ifde(9).Count = 1: ifde(9).Value = width * height * 3
ifde(10).Tag = 284: ifde(10).Type = 3: ifde(10).Count = 1: ifde(10).Value = 1
Put 1, , ifde

offset = 0
Put 1, , offset

'BitsPerSample
ReDim buf(5) As Byte
buf(0) = 8
buf(1) = 0
buf(2) = 8
buf(3) = 0
buf(4) = 8
buf(5) = 0
Put 1, , buf

'------------------------------
Close 1
End Sub

'Tiffファイルの読み込み
'Intel系, IFDは1個, Stripは1個, 24bitフルカラーのみ対応
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

'------------------------------
For i = 0 To num - 1
If ifde(i).Type = 3 And ifde(i).Count = 1 Then
ifde(i).Value = ifde(i).Value Mod CLng(256) * 256
End If
Next i

For i = 0 To num - 1
If ifde(i).Tag = 256 Then
width = ifde(i).Value
ElseIf ifde(i).Tag = 257 Then
height = ifde(i).Value
End If
Next i

For i = 0 To num - 1
If ifde(i).Tag = 258 Then
If ifde(i).Type <> 3 Then GoTo Label1
If ifde(i).Count <> 3 Then GoTo Label1
ReDim buf(5) As Byte
Seek 1, ifde(i).Value + 1
Get 1, , buf
If buf(0) <> 8 Or buf(1) <> 0 Or buf(2) <> 8 Or buf(3) <> 0 Or buf(4) <> 8 Or buf(5) <> 0 Then GoTo Label1
ElseIf ifde(i).Tag = 259 And ifde(i).Value <> 1 Then GoTo Label1
ElseIf ifde(i).Tag = 262 And ifde(i).Value <> 2 Then GoTo Label1
ElseIf ifde(i).Tag = 277 And ifde(i).Value <> 3 Then GoTo Label1
ElseIf ifde(i).Tag = 278 And ifde(i).Value <> height Then GoTo Label1
ElseIf ifde(i).Tag = 279 And ifde(i).Value <> width * height * 3 Then GoTo Label1
ElseIf ifde(i).Tag = 274 And ifde(i).Value <> 1 Then GoTo Label1
ElseIf ifde(i).Tag = 284 And ifde(i).Value <> 1 Then GoTo Label1
End If
Next i

'------------------------------
'画像データ
For i = 0 To num - 1
If ifde(i).Tag = 279 Then
ReDim data(ifde(i).Value - 1) As Byte
End If
Next i

For i = 0 To num - 1
If ifde(i).Tag = 273 Then
Seek 1, ifde(i).Value + 1
Get 1, , data
End If
Next i

'------------------------------
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

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

Excel VBAでSort

　昔作ったExcel VBAのSortのプログラムを見つけました。せっかくなので、以下に載せます。

　10,000個くらいの数値なら一瞬でソートしてくれました。1,000,000個くらいになるとPCが少し固まりました。
　ビッグデータなんてのが流行っていますが、データ件数が1,000,000を超えると処理に時間がかかって大変そうです。

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

Option Explicit

Public Sub test()
Dim i As Long
Dim N As Long
Dim num() As Long

Sheet1.Cells.ClearContents

N = 8
ReDim num(N - 1) As Long

For i = 0 To N - 1
num(i) = N * Rnd()
Next i

For i = 0 To N - 1
Sheet1.Cells(i + 1, 1) = num(i)
Next i

'sort_selection num, N
'sort_insert num, N
sort_quick num, 0, N - 1

For i = 0 To N - 1
Sheet1.Cells(i + 1, 2) = num(i)
Next i
End Sub

'選択ソート
'最小値を見つけて、小さい順に並べる
Public Sub sort_selection(num() As Long, N As Long)
Dim i As Long
Dim j As Long
Dim temp As Long

For i = 0 To N - 1
For j = i To N - 1
If num(j) < num(i) Then
temp = num(i)
num(i) = num(j)
num(j) = temp
End If
Next j
Next i
End Sub

'挿入ソート
'ソートされている部分に後ろから1つずつ値を挿入していく
Public Sub sort_insert(num() As Long, N As Long)
Dim i As Long
Dim j As Long
Dim temp As Long

For i = 0 To N - 1
temp = num(i)

For j = i To 1 Step -1
If temp < num(j - 1) Then
num(j) = num(j - 1)
Else
Exit For
End If
Next j

num(j) = temp
Next i
End Sub

'クイックソート
'pivotの値より大きいか小さいかで選り分ける
Public Sub sort_quick(num() As Long, n1 As Long, n2 As Long)
Dim i As Long
Dim j As Long
Dim pivot As Long
Dim temp As Long

'------------------------------
'すべての値が同じ場合は、ここで終了
For i = n1 To n2
If num(n1) <> num(i) Then Exit For
Next i

If i = n2 + 1 Then Exit Sub

'------------------------------
'pivotを選択 (pivotより小さい値が必ず存在する)
If num(n1) < num(i) Then
pivot = num(i)
Else
pivot = num(n1)
End If

'------------------------------
i = n1
j = n2

Do While True
Do While num(i) < pivot
i = i + 1
Loop

Do While pivot <= num(j)
j = j - 1
Loop

If j < i Then Exit Do

temp = num(i)
num(i) = num(j)
num(j) = temp
Loop

sort_quick num, n1, i - 1
sort_quick num, j + 1, n2
End Sub

登録: 投稿 (Atom)