VBScript で BASE64 の処理をする (unibon)

過去に掲載したコードには、エンコード時にバグがありました。このページは修正済みのものです。古いバグありのものはこちらです。

Option Explicit

Const TransformTable = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Const PaddingChar = "="

' s: 数値型
' w: ビット幅
' 戻り値: 2進数表記の文字列(ビッグエンディアン)
Function encode2(ByVal s, ByVal w)
    Dim b ' 戻り値の2進数表記の文字列(例: 13 = "1101")
    b = ""
    Dim i ' 検査するビット位置(0 は LSB)
    For i = w - 1 To 0 Step -1
        If s And CLng(2 ^ i) Then
            b = b & "1"
        Else
            b = b & "0"
        End If
    Next
    encode2 = b
End Function

' b: 2進数表記の文字列(ビッグエンディアン)
' w: ビット幅
' 戻り値: 数値型
Function decode2(ByVal b, ByVal w)
    Dim c
    c = 0
    Dim i
    For i = 0 To w - 1
        If Mid(b, i + 1, 1) = "1" Then
            c = c Or CLng(2 ^ (w - 1 - i))
        End If
    Next
    decode2 = c
End Function

Function encode64(ByVal s)
    Dim b
    b = ""
    Dim r
    r = ""
    Dim i
    i = 0
    Do
        If i < Len(s) Then
            Dim c
            c = Mid(s, i + 1, 1)
            Dim k
            k = Asc(c)
            If k And &HFF00 Then
                b = b & encode2(k, 16)
            Else
                b = b & encode2(k, 8)
            End If
        Else
            If Len(b) > 0 Then
                Dim j
                For j = 0 To (6 - Len(b)) - 1
                    b = b & "0"
                Next
            End If
        End If

        Do While Len(b) >= 6
            Dim x
            x = Left(b, 6)
            Dim u
            u = decode2(x, 6)
            r = r & Mid(TransformTable, u + 1, 1)
            b = Mid(b, 6 + 1)
        Loop

        If i >= Len(s) Then
            Exit Do
        End If

        i = i + 1
    Loop

    Do While Len(r) Mod 4 > 0
        r = r & PaddingChar
    Loop

    encode64 = r
End Function

Function decodeStreamSJIS(ByRef l, ByVal k)
    Dim r
    If IsNull(l) Then
        If (k >= &H81 And k < &HA0) Or (k >= &HE0 And k < &HF0) Then ' シフト JIS としての lead (先頭のバイト)だった。
            r = Null
            l = k
        Else
            r = Chr(k) ' いわゆる ANK だった。
        End If
    Else ' シフト JIS としての trail (末尾のバイト)だった。
        r = Chr(l * &H100 + k)
        l = Null
    End If
    decodeStreamSJIS = r
End Function

Function DecodeCoreJIS(ByVal s)
    Dim r
    r = ""
    Dim p
    p = 1 ' 1 オリジン
    Do
        If p - 1 >= Len(s) Then
            Exit Do
        End If
        Dim a
        a = Asc(Mid(s, p, 1))
        p = p + 1

        If p - 1 >= Len(s) Then
            Exit Do
        End If
        Dim b
        b = Asc(Mid(s, p, 1))
        p = p + 1

        Dim c
        c = a - &H21
        Dim d
        d = b - &H21

        Dim x
        x = c \ 2 + &H81
        If x >= &HA0 Then
            x = x + &H40
        End If

        Dim y
        y = d + &H40
        If c Mod 2 Then
            y = y + &H5E
        End If
        If y >= &H7F Then
            y = y + 1
        End If

        r = r & Chr(CLng(x) * &H100 + y)
    Loop
    DecodeCoreJIS = r
End Function

Function decodeStreamEUC(ByRef l, ByVal k)
    Dim r
    If IsNull(l) Then
        If k And &H80 Then ' EUC としての lead (先頭のバイト)だった。
            r = Null
            l = k
        Else
            r = Chr(k) ' いわゆる ANK だった。
        End If
    Else ' EUC としての trail (末尾のバイト)だった。
        If l = &H8E Then ' 半角カナ
            r = Chr(k)
        Else
            r = DecodeCoreJIS(Chr(l And &H7F) & Chr(k And &H7F))
        End If
        l = Null
    End If
    decodeStreamEUC = r
End Function

Function decode64(ByVal t)
    Dim b
    b = ""
    Dim r
    r = ""
    Dim l
    l = Null
    Dim i
    For i = 0 To Len(t) - 1
        Dim c
        c = Mid(t, i + 1, 1)
        If c = PaddingChar Then
            Exit For
        End If

        Dim p
        p = InStr(1, TransformTable, c)
        If p < 1 Then
            decode64 = Null
            Exit Function
        Else
            b = b & encode2(p - 1, 6)
            Do While Len(b) >= 8
                Dim x
                x = Left(b, 8)
                Dim k
                k = decode2(x, 8)
                Dim y
                y = decodeStreamSJIS(l, k) ' シフト JIS として解釈する場合。
                ' y = decodeStreamEUC(l, k) ' EUC として解釈する場合。
                If Not IsNull(y) Then
                    r = r & y
                End If
                b = Mid(b, 8 + 1)
            Loop
        End If
    Next
    decode64 = r
End Function

Dim x
x = "hogehogeほげほげ"
Dim y
y = encode64(x)
Dim z
z = decode64(y)
Dim s
s = x & " → "  & y  & " → "  & z
Call MsgBox(s) ' WSH や HTML(クライアントサイド)の場合
' Call Response.Write(s) ' ASP のサーバサイドの場合