BinaryReader for VBA

BinaryReader.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "BinaryReader"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Binary
Option Explicit

'/******************************************************
' * Reader class for binary data.
' * @author YU-TANG
' ******************************************************

#If VBA7 Then
Private Declare PtrSafe Function NetworkToHostLong Lib "Ws2_32.dll" Alias "ntohl" ( _
    ByVal netlong As Long _
) As Long

Private Declare PtrSafe Function NetworkToHostShort Lib "Ws2_32.dll" Alias "ntohs" ( _
    ByVal netshort As Integer _
) As Integer
#Else
Private Declare Function NetworkToHostLong Lib "Ws2_32.dll" Alias "ntohl" ( _
    ByVal netlong As Long _
) As Long

Private Declare Function NetworkToHostShort Lib "Ws2_32.dll" Alias "ntohs" ( _
    ByVal netshort As Integer _
) As Integer
#End If

Private filePath   As String
Private fileHandle As Integer
Private markpos    As Long      ' 1 ～ 2,147,483,647 (= 2^31-1)

'====================================================================
' Event Procedures
'====================================================================
Private Sub Class_Initialize()
'
End Sub

Private Sub Class_Terminate()
Call CloseFile
End Sub

'====================================================================
' Public Procedures
'====================================================================

'--------------------------------------------------------------------
' Open / Close
'--------------------------------------------------------------------

Public Function OpenFile(ByRef FileName As String) As BinaryReader
Call CloseFile

filePath = FileName
fileHandle = FreeFile()
Open filePath For Binary Access Read Lock Write As #fileHandle
Set OpenFile = Me
End Function

Public Function CloseFile() As BinaryReader
If fileHandle <> 0 Then
    Close #fileHandle
End If
fileHandle = 0
markpos = 0
filePath = vbNullString
Set CloseFile = Me
End Function

'--------------------------------------------------------------------
' Pointer operations
'--------------------------------------------------------------------

Public Function Skip(ByVal offsetFromCurrentPositionInBytes As Long) As BinaryReader
Dim pos As Long: pos = Seek(fileHandle)  ' 1 ～ 2,147,483,647 (= 2^31-1)
Seek #fileHandle, pos + offsetFromCurrentPositionInBytes
Set Skip = Me
End Function

' addressOffset must be 0 or higher
Public Function MoveTo(ByVal addressOffset As Long) As BinaryReader
Seek #fileHandle, addressOffset + 1 ' Seek() uses 1 origin. +1 to offset.
Set MoveTo = Me
End Function

Public Function mark() As BinaryReader
markpos = Seek(fileHandle)
Set mark = Me
End Function

' markpos の位置に移動します。
' -- markpos が無効（1 未満）の場合は、エラーを発生させず、単に無視されます。
Public Function Reset() As BinaryReader
If markpos < 1 Then Exit Function
Seek #fileHandle, markpos
Set Reset = Me
End Function

' markpos の位置を基準に、offsetFromCurrentPositionInBytes 分移動します。
' -- markpos が無効（1 未満）の場合は、エラーを発生させず、現在位置を基準に移動します。
Public Function ResetAndSkip(ByVal offsetFromCurrentPositionInBytes As Long) As BinaryReader
Dim pos As Long
If markpos < 1 Then
    pos = Seek(fileHandle)  ' 1 ～ 2,147,483,647 (= 2^31-1)
Else
    pos = markpos
End If
Seek #fileHandle, pos + offsetFromCurrentPositionInBytes
Set ResetAndSkip = Me
End Function

' ファイルの先頭にポインタを戻します。
Public Function Rewind() As BinaryReader
Seek #fileHandle, 1
Set Rewind = Me
End Function

'--------------------------------------------------------------------
' Read operations
'--------------------------------------------------------------------

Public Function Read(ByVal Length As Long) As Byte()
ReDim Read(Length - 1)
Get #fileHandle, , Read
End Function

' 文字列を読み込みます。
' -- 元データは OS 既定の文字エンコード（日本語 OS 上だと SJIS）を想定しています。
Public Function ReadString(ByVal charCount As Long) As String
If charCount = 0 Then Exit Function
ReadString = Space(charCount)
Get #fileHandle, , ReadString
End Function

' 文字列を読み込みます。
' -- 元データは OS 既定の文字エンコード（日本語 OS 上だと SJIS）を想定しています。
' -- 引数 byteCount には読み込み元のバイト数を指定します。
Public Function ReadStringInBytes(ByVal byteCount As Long) As String
If byteCount = 0 Then Exit Function
ReDim buff(byteCount - 1) As Byte
Get #fileHandle, , buff
ReadStringInBytes = StrConv(buff, vbUnicode)
End Function

' Unicode 文字列を読み込みます。
' -- サロゲート文字には対応していません。
' -- 引数 charCount には読み込み元の文字数を指定します。バイト数ではないので注意。
Public Function ReadUnicodeString(ByVal charCount As Long) As String
If charCount = 0 Then Exit Function
ReDim buff(charCount * 2 - 1) As Byte
Get #fileHandle, , buff
ReadUnicodeString = buff
End Function

' UTF-8 文字列を読み込みます。
' -- サロゲート文字には対応していません（読める場合もあるかもしれませんが、保証はしません）。
' -- 引数 charCount には読み込み元の文字数を指定します。バイト数ではないので注意。
Public Function ReadUTF8String(ByVal charCount As Long) As String
If charCount = 0 Then Exit Function
' UTF-8 はバイト長が不定なので、最大桁（一文字 6 バイト）を担保できるバッファを確保しておく
ReDim buff(charCount * 6 - 1) As Byte
Get #fileHandle, , buff

Dim strm As Object: Set strm = CreateObject("ADODB.Stream")
Dim ret  As String

' write bytes to stream
strm.Type = 1   ' adTypeBinary
strm.Mode = 3   ' adModeReadWrite
strm.Open
strm.Write buff

' read string from stream
strm.Position = 0
strm.Type = 2   ' adTypeText
strm.Charset = "UTF-8"
ret = strm.ReadText
strm.Close: Set strm = Nothing

' return result
ReadUTF8String = Left(ret, charCount)
End Function

Public Function ReadInteger() As Integer
Get #fileHandle, , ReadInteger
End Function

' Read integer from Big-Endian byte order
Public Function ReadIntegerBE() As Integer
Get #fileHandle, , ReadIntegerBE
ReadIntegerBE = NetworkToHostShort(ReadIntegerBE)
End Function

Public Function ReadLong() As Long
Get #fileHandle, , ReadLong
End Function

' Read long from Big-Endian byte order
Public Function ReadLongBE() As Long
Get #fileHandle, , ReadLongBE
ReadLongBE = NetworkToHostLong(ReadLongBE)
End Function

'--------------------------------------------------------------------
' Information
'--------------------------------------------------------------------

Public Property Get FileName() As String
FileName = filePath
End Property

' return 0 ～
Public Property Get CurrentOffset() As Long
CurrentOffset = (Seek(fileHandle) - 1)
End Property

' return 0 ～
Public Property Get Handle() As Integer
Handle = fileHandle
End Property