某所のカウンター GIF 画像を数値変換するデモ(Excel VBA)。

BinaryReader.cls

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    Destination As Any, _
    Source As Any, _
    ByVal Length As Long _
)

Private Const ERR_INVALID_PROCEDURE_CALL_OR_ARGUMENT As Long = 5  ' プロシージャの呼び出し、または引数が不正です。
Private Const ERR_SUBSCRIPT_OUT_OF_RANGE             As Long = 9  ' インデックスが有効範囲にありません。

Private buff() As Byte
Private pos    As Long
Private marked As Long

Public Property Let data(Bytes() As Byte)
buff = Bytes
pos = LBound(Bytes)
marked = pos
End Property

Public Property Get EOF() As Boolean
EOF = (pos > UBound(buff))
End Property

Public Property Get Position() As Long
Position = pos
End Property

Public Function Read(ParamArray Params() As Variant) As BinaryReader
If IsMissing(Params) Then
    Err.Raise ERR_SUBSCRIPT_OUT_OF_RANGE
End If

Dim i As Integer
For i = LBound(Params) To UBound(Params)
    Select Case VarType(Params(i))
        Case vbByte:    Params(i) = ReadByte
        Case vbInteger: Params(i) = ReadInteger
        Case vbLong:    Params(i) = ReadLong
        Case vbString:  Params(i) = ReadASCII(Len(Params(i)))
        Case Else:  Err.Raise ERR_INVALID_PROCEDURE_CALL_OR_ARGUMENT
    End Select
Next

Set Read = Me
End Function

Public Function ReadByte(Optional BeforeMoveTo As Long = -1) As Byte
Dim BasePosition As Long: BasePosition = GetBasePosition(BeforeMoveTo)
RaiseErrorIfInvalidPos BasePosition

ReadByte = buff(BasePosition)
pos = BasePosition + 1
End Function

Public Function ReadInteger(Optional BeforeMoveTo As Long = -1) As Integer
Dim BasePosition As Long: BasePosition = GetBasePosition(BeforeMoveTo)
RaiseErrorIfInvalidPos BasePosition + 1

CopyMemory ReadInteger, buff(BasePosition), 2&
pos = BasePosition + 2
End Function

Public Function ReadLong(Optional BeforeMoveTo As Long = -1) As Long
Dim BasePosition As Long: BasePosition = GetBasePosition(BeforeMoveTo)
RaiseErrorIfInvalidPos BasePosition + 3

CopyMemory ReadLong, buff(BasePosition), 4&
pos = BasePosition + 4
End Function

Public Function ReadCurrency(Optional BeforeMoveTo As Long = -1) As Currency
Dim BasePosition As Long: BasePosition = GetBasePosition(BeforeMoveTo)
RaiseErrorIfInvalidPos BasePosition + 7

CopyMemory ReadCurrency, buff(BasePosition), 8&
pos = BasePosition + 8
End Function

Public Function ReadBytes(SizeOfBytes As Long) As Byte()
RaiseErrorIfInvalidPos pos + SizeOfBytes - 1

ReDim Bytes(SizeOfBytes - 1) As Byte
CopyMemory Bytes(0), buff(pos), SizeOfBytes
pos = pos + SizeOfBytes
ReadBytes = Bytes
End Function

Public Function ReadASCII(SizeOfBytes As Long) As String
Dim Bytes() As Byte
Bytes = ReadBytes(SizeOfBytes)
ReadASCII = StrConv(Bytes, vbUnicode)
End Function

Public Function Mark() As Long
RaiseErrorIfInvalidPos pos

marked = pos
Mark = pos
End Function

Public Function MoveTo(TargetPosition As Long) As BinaryReader
RaiseErrorIfInvalidPos TargetPosition

pos = TargetPosition
Set MoveTo = Me
End Function

Public Function Reset() As Long
pos = marked
Reset = pos
End Function

Public Function Rewind() As BinaryReader
pos = LBound(buff)
Set Rewind = Me
End Function

Public Function Skip(Optional Offset As Long = 1) As BinaryReader
pos = pos + Offset
Set Skip = Me
End Function

' パックされた 1 バイトを読み込んで、各フィールドに分割した配列を返します。
' 引数 BitsArray には 7 -> 0 のビット順で各フィールドのビット数を指定した配列を渡します。
' 引数 BitsArray を省略した場合は、1 ビット単位の 8 要素の配列を返します。
' 引数 BitsArray で指定したビット数の合計が 8 未満でも問題ありませんが、8 以上の場合は未定義です。
' 使用例：
' たとえば次のようなパックされた構造体を読みたいとします。
' | 7| 6| 5| 4| 3| 2| 1| 0|(bit)
' +--+--+--+--+--+--+--+--+
' |F1| F2  |  F3 |   F4   |(field)
' この場合は次のように指定します。
' ReadPack(Array(1, 2, 2, 3))
Public Function ReadPack(Optional BitsArray As Variant) As Byte()
If IsMissing(BitsArray) Then
    BitsArray = Array(1, 1, 1, 1, 1, 1, 1, 1)
End If

Dim src         As Byte: src = ReadByte()
Dim bits(7)     As Byte
Dim i           As Integer

' split in bits
For i = 0 To 7
    bits(i) = src And 2 ^ i
Next

ReDim ret(UBound(BitsArray) - LBound(BitsArray)) As Byte
Dim j       As Integer
Dim bitPos  As Integer: bitPos = 7
Dim bitPos2 As Integer

For i = LBound(ret) To UBound(ret)
    bitPos2 = bitPos - BitsArray(i)
    For j = bitPos To (bitPos2 + 1) Step -1
        ret(i) = ret(i) + bits(j)
    Next
    ret(i) = ret(i) \ (2 ^ (bitPos2 + 1))
    bitPos = bitPos2
Next
ReadPack = ret
End Function

Private Sub RaiseErrorIfInvalidPos(ByVal pos As Long)
If pos < LBound(buff) Or pos > UBound(buff) Then
    Err.Raise ERR_SUBSCRIPT_OUT_OF_RANGE
End If
End Sub

Private Function GetBasePosition(ByVal BeforeMoveTo As Long) As Long
If BeforeMoveTo = -1 Then
    GetBasePosition = pos
Else
    GetBasePosition = BeforeMoveTo
End If
End Function

GIFReader.cls

' GIF 画像からフレーム単位のイメージデータの先頭8バイトの配列を取得するためのクラスです。
'   某サイトのカウンター用 GIF 画像を前提にした、必要最小限の決め打ち処理です。
'   汎用の作りではありませんので、上記以外のファイルを渡すと死にます。
'
' @see http://www.snap-tck.com/room03/c02/cg/cg04_02.html#cg042
' @see http://www.tohoho-web.com/wwwgif.htm
'================================================
Option Explicit

Private reader         As New BinaryReader
Private posImageData() As Long

Public Function Load(PathOrURL As String) As GIFReader
If PathOrURL Like "http://*" Or PathOrURL Like "https://*" Then
    reader.data = ReadURLAsBinary(PathOrURL)
Else
    reader.data = ReadFileAsBinary(PathOrURL)
End If

ExtractStructure reader
Set Load = Me
End Function

Public Function GetImageDataHeadArray() As Currency()
Dim i As Integer
ReDim head(UBound(posImageData)) As Currency

For i = LBound(posImageData) To UBound(posImageData)
    head(i) = reader.ReadCurrency(BeforeMoveTo:=posImageData(i))
Next

GetImageDataHeadArray = head
End Function

' Return True if succeed.
Private Function ExtractStructure(reader As BinaryReader) As Boolean
Const GIF_TRAILER               As Byte = &H3B
Const GIF_IMAGE_BLOCK_SEPARATOR As Byte = &H2C
Const GIF_EXTENSION_INTRODUCER  As Byte = &H21
Const GIF_GRAPHIC_CONTROL_LABEL As Byte = &HF9
Dim imageDataSize() As Integer

' erase array for ImageData positions
Erase posImageData

' check signature
If reader.ReadASCII(3) <> "GIF" Then
    Debug.Print "Not GIF."
    Exit Function
End If

' skip header
reader.Skip 10

' read body
Do While True
    Select Case reader.ReadByte
    Case GIF_IMAGE_BLOCK_SEPARATOR
        AddPosImageData ReadImageBlock(reader)
    Case GIF_EXTENSION_INTRODUCER
        Select Case reader.ReadByte
        Case GIF_GRAPHIC_CONTROL_LABEL
            If ReadGraphicControlExtensionBlock(reader) = 0 Then
                Exit Do
            End If
        Case Else
            Exit Do
        End Select
    Case GIF_TRAILER
        Exit Do
    Case Else
        Exit Do ' not available
    End Select
Loop

ExtractStructure = True
End Function

Private Function ReadFileAsBinary(FilePath As String) As Byte()
Dim fh As Integer: fh = FreeFile()
Open FilePath For Binary Access Read As #fh
Dim fileLength As Long: fileLength = LOF(fh)
ReDim ReadFileAsBinary(fileLength - 1)
Get #fh, , ReadFileAsBinary
Close #fh
End Function

Private Function ReadURLAsBinary(url As String) As Byte()
' きぬあささんの投稿よりコピー
With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", url, False
    .setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT" 'キャッシュ対策(日付は適当)
    .Send
    ReadURLAsBinary = .responseBody
End With
End Function

' return size of read bytes. return 0 if error occured.
Private Function ReadGraphicControlExtensionBlock(reader As BinaryReader) As Long
Const BLOCK_TERMINATOR = &H0
Dim markedPos As Long: markedPos = reader.Mark

reader.Skip 5  ' just skip and ignore
If reader.ReadByte <> BLOCK_TERMINATOR Then
    Debug.Print "Error: BLOCK_TERMINATOR not found."
    reader.Reset
End If
ReadGraphicControlExtensionBlock = reader.Position - markedPos
End Function

' return pos of image data
Private Function ReadImageBlock(reader As BinaryReader) As Long
Const BLOCK_TERMINATOR = &H0
Dim localColorTablePack()           As Byte
Dim localColorTableFlag             As Boolean
Dim sizeofLocalColorTable           As Long
Dim sizeofLocalColorTableEntries    As Long
Dim sizeofImageData                 As Long
Dim posImageData                    As Long

reader.Skip 8
' Image Left Position(2B)
' Image Top Position(2B)
' Image Width(2B)
' Image Height(2B)

localColorTablePack = reader.ReadPack(Array(1, 1, 1, 2, 3))
' LCTF(1b)    IF(1b)  SF(1b)  R(2b)   SLCT(3b)

' Local Color Table
localColorTableFlag = localColorTablePack(0)
If localColorTableFlag Then
    sizeofLocalColorTable = localColorTablePack(4)
    sizeofLocalColorTableEntries = 2 ^ (sizeofLocalColorTable + 1)
    reader.Skip sizeofLocalColorTableEntries * 3
End If

' Image Data
Do While True
    Select Case reader.ReadByte
    Case BLOCK_TERMINATOR
        Exit Do
    Case Else ' LZW Minimum Code Size
        sizeofImageData = reader.ReadByte
        If posImageData = 0 Then
            posImageData = reader.Position
        End If
        reader.Skip sizeofImageData
    End Select
Loop

ReadImageBlock = posImageData
End Function

Private Sub AddPosImageData(NewPos As Long)
If Not Not posImageData Then
    ReDim Preserve posImageData(UBound(posImageData) + 1)
Else
    ReDim posImageData(0)
End If
posImageData(UBound(posImageData)) = NewPos
End Sub

Test.bas

Option Explicit

Public Sub GetCounterSample()
    MsgBox GetCounter("http://www.okazaki-gakku-fukushi.com/ueji/")
End Sub

Public Function GetCounter(ByVal url As String) As Long
Dim reader As New GIFReader
Dim hashs() As Currency
Dim hash    As Variant
Dim numbers As String

If url Like "http*" And Not url Like "*.cgi" Then
    If Right(url, 1) <> "/" Then url = url & "/"
    url = url & "counter/counter.cgi"
End If

hashs = reader.Load(url).GetImageDataHeadArray()
For Each hash In hashs
    ' Debug.Print hash
    numbers = numbers & GetNumber(CCur(hash))
Next

If IsNumeric(numbers) Then
    GetCounter = Val(numbers)
Else
    Debug.Print numbers
End If
End Function

Private Function GetNumber(hash As Currency) As String
Static table() As Variant
If (Not Not table) = 0 Then ' 未初期化の場合
    table = GetNumbersHashTable()
End If

Dim i As Integer
For i = LBound(table) To UBound(table)
    If hash = table(i) Then
        GetNumber = CStr(i \ 4)
        Exit Function
    End If
Next

' ここを通るのは、対応する数字が見つからなかった場合
Debug.Print hash & "@ is not found in hash table."
GetNumber = "?"
End Function

Private Function GetNumbersHashTable() As Variant()
' Image data block の先頭8バイトを Currency 型の表にしたもの。
' [青, 緑, 黄, ピンク] の 4 要素単位で [数字順(0->9)] になっている。
' ソースコードは見かけ上、行ごとに数字順、列ごとに色順に並ぶように整形してある。
GetNumbersHashTable = Array( _
    162398209589285.912@, 699297989234302.2176@, -294513371852506.504@, -662685651303125.5856@, _
    310186639346642.3536@, 310524409318695.1408@, 310636373962141.1024@, 310636370526167.2656@, _
    249066906558567.4448@, 252673315220342.6064@, -884921217519755.0416@, 263492509422910.0752@, _
    -222582696889904.1008@, -217912576559925.5904@, -106840076730067.9472@, 469732939253899.4928@, _
    425622825937939.8896@, 425967852686736.0048@, 426276633347527.7008@, 426305660454500.9872@, _
    673098877990245.4064@, -364541140868413.608@, 442507649404068.0656@, -479850445012403.5856@, _
    728272118548907.8512@, 739076479867170.2288@, 695926214754577.8384@, 695926214754577.8416@, _
    366683617444402.2@, -847349572052096.5536@, 363080764371303.032@, 363080737313009.0736@, _
    584491407278930.5552@, -210317603783795.4528@, -89709331771386.8624@, 469772208998880.28@, _
    585025622183154.7088@, 356826326790505.3216@, 260787264034608.1456@, 610044603828284.8464@ _
)
End Function