Option Explicit

'===== UTF-8 変換モジュール =====
'(C)2002-2011 ばら
'MAIL : http://www.geocities.co.jp/SilkRoad/4511/mail.htm
'HOME : http://www.geocities.co.jp/SilkRoad/4511/
'
'VB のみで、UTF-8 のエンコード・デコードを実現するモジュールです。
'WideCharToMultiByte() 等は使用しないため、Windows 95 など
'UTF-8 のエンコードに対応していない古い Windows でも使用可能です。
'まあ、処理速度は確実に遅いでしょう(^^;

Private Const ISUTF8_DEFAULT_READSIZE = 256 'IsUtf8 関数内部で使用されます
Private Const ISUTF8_DEFAULT_UTF8COUNT = 2

'----- Utf8Encode 関数 Ver 1.02 -----
'VB の Unicode 文字列を、UTF-8 エンコードします。
'
'引数 strUnicode
'   UTF-8 エンコードの対象となる文字列式を指定します。
'
'引数 bytUtf8()
'   UTF-8 エンコードされたデータを受け取るバイト型動的配列を
'   指定します。配列サイズは関数内で初期化されますので、
'   宣言のみを行い渡して下さい。
'
'引数 blnAddBOM
'   省略可能です。UTF-8 エンコードしたバイト型配列の先頭に、
'   UTF-8 であることを表す 3 バイトの BOM(Byte Order Mark) を
'   付加するか否かを指定します。
'
'   True  - BOM を付加します。
'   False - BOM を付加しません。(規定値)
'
'戻り値
'   関数が成功した場合、bytUtf8() に書き込んだサイズを返します。
'   失敗した場合は、0 が返ります。
'
'Windows 95 の WideCharToMultiByte() では UTF-8 変換ができないため、
'RFC2279 を参考に自分で作ってみました。VB の内部処理に用いられている
'文字列はもともと Unicode なので、UTF-8 との相互変換は簡単にできます。
'Ver 1.02 より BOM の付加も可能になりました。
'
Public Function Utf8Encode _
    (ByRef strUnicode As String, _
     ByRef bytUtf8() As Byte, _
     Optional ByVal blnAddBOM As Boolean = False) As Long

 Dim lngUnicodeLength As Long                                                               'Unicode 文字列の長さを格納する変数
 Dim lngUtf8Size As Long                                                                    'UTF-8 エンコードされたサイズを格納する変数
 Dim lngCharCode As Long                                                                    '1 文字分の文字コードを格納する長整数型変数
 Dim i As Long                                                                              'ループカウンタ
 
    lngUnicodeLength = Len(strUnicode)                                                      'Unicode 文字列長を得る
    If lngUnicodeLength = 0 Then Exit Function                                              '0 文字の場合関数を抜ける
    ReDim bytUtf8((lngUnicodeLength * 3) + IIf(blnAddBOM, 3, 0) - 1)                        'UTF-8 バッファサイズを確保(念のため文字列長の 3 倍)
    
    If blnAddBOM Then                                                                       'BOM を付加する場合
        bytUtf8(0) = &HEF                                                                   '配列先頭 3 バイトに BOM を書き込む
        bytUtf8(1) = &HBB
        bytUtf8(2) = &HBF
        lngUtf8Size = 3                                                                     'UTF-8 書き込みカウンタを 3 にする
    End If
    
    For i = 1 To lngUnicodeLength Step 1                                                    '文字列の終端までループ
        lngCharCode = CLng(AscW(Mid$(strUnicode, i, 1))) And &HFFFF&                        'i 文字目の 1 文字の文字コードを得、正の値に変換
        If lngCharCode <= &H7F& Then                                                        '文字コードが &H7F 以下の場合
            bytUtf8(lngUtf8Size) = CByte(lngCharCode)                                       'ANSI は変換する必要がないのでそのまま代入
            lngUtf8Size = lngUtf8Size + 1                                                   '1 バイト書き込んだので書き込みカウンタに 1 を加算
        ElseIf (lngCharCode >= &H80&) And (lngCharCode <= &H7FF&) Then                      '文字コードが &H80 〜 &H7FF の場合
            '----- UTF-8 エンコード 1 バイト目の処理 -----
            '1.lngCharCode を 6 ビット右シフトし上位ビット(2 〜 5)の値を得る
            '2.上記の処理により得られた値と 11000000(2 進数) との論理和を求める
            bytUtf8(lngUtf8Size) = CByte((lngCharCode \ &H40&) Or &HC0&)                    '得られた値を配列に代入
            '----- UTF-8 エンコード 2 バイト目の処理 -----
            '1.lngCharCode と 00111111(2 進数) との論理積を求め、下位 6 ビットの値を得る
            '2.上記の処理により得られた値と 10000000(2 進数) との論理和を求める
            bytUtf8(lngUtf8Size + 1) = CByte((lngCharCode And &H3F&) Or &H80&)              '得られた値を配列に代入
            lngUtf8Size = lngUtf8Size + 2                                                   '2 バイト書き込んだので書き込みカウンタに 2 を加算
        ElseIf (lngCharCode >= &H800&) And (lngCharCode <= &HFFFF&) Then                    '文字コードが &H800 〜 &HFFF の場合
            '----- UTF-8 エンコード 1 バイト目の処理 -----
            '1.lngCharCode を 12 ビット右シフトし上位ビット(0 〜 4)の値を得る
            '2.上記の処理により得られた値と 11100000(2 進数) との論理和を求める
            bytUtf8(lngUtf8Size) = CByte((lngCharCode \ &H1000&) Or &HE0&)                  '得られた値を配列に代入
            '----- UTF-8 エンコード 2 バイト目の処理 -----
            '1.lngCharCode と 00001111 11000000(2 進数) との論理和を求め、中間 6 ビット以外を 0(2 進数) にする
            '2.上記の処理により得られた値を 6 ビット右シフトし、lngCharCode の中間 6 ビットの値を得る
            '3.上記の処理により得られた値と 10000000(2 進数) との論理和を求める
            bytUtf8(lngUtf8Size + 1) = CByte(((lngCharCode And &HFC0&) \ &H40&) Or &H80&)   '得られた値を配列に代入
            '----- UTF-8 エンコード 3 バイト目の処理 -----
            '1.lngCharCode と 00111111(2 進数) との論理積を求め、下位 6 ビットの値を得る
            '2.上記の処理により得られた値と 10000000(2 進数) との論理和を求める
            bytUtf8(lngUtf8Size + 2) = CByte((lngCharCode And &H3F&) Or &H80&)              '得られた値を配列に代入
            lngUtf8Size = lngUtf8Size + 3                                                   '3 バイト書き込んだので書き込みカウンタに 3 を加算
        End If
    Next i
    
    If lngUtf8Size Then                                                                     'バッファにデータが書き込まれた場合
        ReDim Preserve bytUtf8(lngUtf8Size - 1)                                             'バッファサイズを実際のサイズに削る
        Utf8Encode = lngUtf8Size                                                            'バッファに書き込んだサイズを返す
    End If

End Function

'----- Utf8Decode Ver 1.03 -----
'UTF-8 エンコードされた文字列を、VB 標準の Unicode 文字列に
'デコードします。UCS-2 のみの対応です。
'
'引数 bytUtf8()
'   UTF-8 エンコードされた文字列が格納されているバイト型配列を
'   指定します。
'
'引数 strDefaultChar
'   省略可能です。UTF-8 エンコードされた文字として不正な文字が
'   見つかった場合に、代わりに使用する文字列式を指定します。
'   この引数を省略すると、長さ 0 の文字列が使用されます。
'
'戻り値
'   関数が成功した場合、UTF-8 デコードした文字列が返ります。
'
'UTF-8 エンコード処理を作ったのなら、デコード処理も作らないと
'かっこ悪いので作ってみました。論理演算を文で表すのが難しく、
'計算処理部のコメントは省略しました(^^;
'Ver 1.03 より BOM 付き UTF-8 にも対応しました。
'
Public Function Utf8Decode _
    (ByRef bytUtf8() As Byte, _
     Optional ByRef strDefaultChar As String) As String

 Dim lngUtf8Size As Long                                                                                'UTF-8 文字列配列のサイズを格納する変数
 Dim lngDefaultCharLength As Long                                                                       '代替文字列のサイズを格納する変数
 Dim strBuffer As String                                                                                'Unicode 文字列を格納するバッファ
 Dim lngWriteLength As Long                                                                             '書き込み位置カウンタ
 Dim bytUcs2Char(1) As Byte                                                                             'Unicode(UCS-2) 1 文字分を格納するバイト型配列
 Dim i As Long                                                                                          '読み込み位置カウンタ

    On Error GoTo ExitFunction                                                                          'エラーが発生したら関数を抜ける
    lngUtf8Size = UBound(bytUtf8)                                                                       '配列サイズを得る
    On Error GoTo 0                                                                                     'エラートラップの無効化
    lngDefaultCharLength = Len(strDefaultChar)                                                          '代替文字列の文字列数を得る
    If lngDefaultCharLength Then                                                                        '代替文字列が指定されている場合
        strBuffer = String$((lngUtf8Size + 1) * lngDefaultCharLength, vbNullChar)                       'バッファを配列サイズの代替文字列数倍サイズ確保
    Else                                                                                                '代替文字列が指定されていない場合
        strBuffer = String$(lngUtf8Size + 1, vbNullChar)                                                'バッファを配列サイズと同サイズ確保
    End If
    lngWriteLength = 1                                                                                  '書き込みカウンタは 1 から開始
    
    If lngUtf8Size >= 2 Then                                                                            'UTF-8 文字列配列が 3 バイト以上の場合
        If bytUtf8(0) = &HEF And bytUtf8(1) = &HBB And bytUtf8(2) = &HBF Then i = 3                     'BOM がある場合はスキップし、読み込みカウンタを 3 から開始
    End If
    
    Do While i <= lngUtf8Size                                                                           '配列の終端までループ
        If bytUtf8(i) <= &H7F Then                                                                      'ANSI 標準文字の場合
            Mid(strBuffer, lngWriteLength, 1) = ChrW$(bytUtf8(i))                                       '文字コードを文字列に変換しバッファに書き込む
            lngWriteLength = lngWriteLength + 1                                                         '書き込みカウンタをインクリメント
            i = i + 1                                                                                   '読み込みカウンタをインクリメント
        ElseIf (bytUtf8(i) >= &HC2 And bytUtf8(i) <= &HDF) Then                                         'UTF-8 2 バイトコードの第 1 バイトらしい場合
            If (i + 1) <= lngUtf8Size Then                                                              '配列の終端に達していない場合
                If (bytUtf8(i + 1) >= &H80 And bytUtf8(i + 1) <= &HBF) Then                             '後ろ 1 バイトも UTF-8 のバイト列である場合
                    bytUcs2Char(0) = ((bytUtf8(i) And &H3) * &H40) Or (bytUtf8(i + 1) And &H3F)         'デコード処理(Unicode 上位バイト)
                    bytUcs2Char(1) = (bytUtf8(i) And &H1C) \ &H4                                        'デコード処理(Unicode 下位バイト)
                    Mid(strBuffer, lngWriteLength, 1) = bytUcs2Char                                     'bytUcs2Char バイト配列をバッファに書き込む
                    lngWriteLength = lngWriteLength + 1                                                 '書き込みカウンタをインクリメント
                    i = i + 2                                                                           '読み込みカウンタを 2 増やす
                Else                                                                                    'その他の文字の場合
                    If lngDefaultCharLength Then GoSub SetDefaultChar                                   '代替文字が指定されている場合、SetDefaultChar ラベルに飛ぶ
                    i = i + 1                                                                           '読み込みカウンタをインクリメント
                End If
            Else
                If lngDefaultCharLength Then GoSub SetDefaultChar
                i = i + 1
            End If
        ElseIf (bytUtf8(i) >= &HE0 And bytUtf8(i) <= &HEF) Then                                         'UTF-8 3 バイトコードの第 1 バイトらしい場合
            If (i + 2) <= lngUtf8Size Then                                                              '配列の終端に達していない場合
                If (bytUtf8(i + 1) >= &H80 And bytUtf8(i + 1) <= &HBF) And _
                   (bytUtf8(i + 2) >= &H80 And bytUtf8(i + 2) <= &HBF) Then                             '後ろ 2 バイトも UTF-8 のバイト列である場合
                    bytUcs2Char(0) = ((bytUtf8(i + 1) And &H3) * &H40) Or (bytUtf8(i + 2) And &H3F)     'デコード処理(Unicode 上位バイト)
                    bytUcs2Char(1) = ((bytUtf8(i) And &HF) * &H10) Or ((bytUtf8(i + 1) And &H3C) \ &H4) 'デコード処理(Unicode 下位バイト)
                    Mid(strBuffer, lngWriteLength, 1) = bytUcs2Char                                     'bytUcs2Char バイト配列をバッファに書き込む
                    lngWriteLength = lngWriteLength + 1                                                 '書き込みカウンタをインクリメント
                    i = i + 3                                                                           '読み込みカウンタを 3 増やす
                Else
                    If lngDefaultCharLength Then GoSub SetDefaultChar
                    i = i + 1
                End If
            Else
                If lngDefaultCharLength Then GoSub SetDefaultChar
                i = i + 1
            End If
        Else
            If lngDefaultCharLength Then GoSub SetDefaultChar
            i = i + 1
        End If
    Loop

    Utf8Decode = Left$(strBuffer, lngWriteLength - 1)                                                   'バッファから余分な部分を除いた文字列を戻り値とする

    Exit Function
    
SetDefaultChar:                                                                                         '代替文字セットラベル
    Mid(strBuffer, lngWriteLength, lngDefaultCharLength) = strDefaultChar                               '代替文字をバッファに書き込む
    lngWriteLength = lngWriteLength + lngDefaultCharLength                                              '書き込みカウンタを代替文字数増やす
    Return                                                                                              '復帰

ExitFunction:

End Function

'----- IsUtf8 関数 Ver 1.02 Beta -----
'バイト型配列に格納されている文字列が UTF-8 であるかどうか判別します。
'
'引数 bytArray()
'   文字列が格納されているバイト型配列を指定します。
'
'引数 lngReadSize
'   省略可能です。文字列判別対象とするバイト数を指定します。
'   この引数を省略すると ISUTF8_DEFAULT_READSIZE の値が使用されます。
'   bytArray() のサイズ(要素数)がここで指定されたサイズ以下の場合、
'   bytArray() のサイズに丸められます。数値を大きくすればするほど
'   判別の信頼性は増しますが、処理時間を多く要することになります。
'
'引数 lngUtf8Count
'   省略可能です。ここに指定した値の回数だけ UTF-8 と確定された場合、
'   UTF-8 と判断して関数が True を返すように指定できます。
'   確定回数が指定された値よりも少ない場合は False を返します。
'   判別の信頼性を増すためにも、2 以上の値を推奨します。
'   この引数を省略すると ISUTF8_DEFAULT_UTF8COUNT の値が使用されます。
'
'引数 blnCountStop
'   省略可能です。ここに True を指定すると、lngUtf8Count に指定した
'   値の回数だけUTF-8 と確定された場合、ただちに判別処理を中止し
'   関数が True を返します。厳密に判定したい場合は使用しないでください。
'
'   True  - 指定回数に達したら関数を抜けます。
'   False - 指定回数に達しても判別を継続します。(規定値)
'
'引数 blnTrustBOM
'   省略可能です。ここに True を指定すると、UTF-8 を表す BOM が
'   存在する場合、ただちに関数を抜け無条件で関数が True を返します。
'
'   True  - 無条件で BOM を信用します。
'   False - BOM を無視して判別を行います。(規定値)
'
'戻り値
'   bytArray() に格納されている文字列が UTF-8 であると判別された
'   場合は True を返します。ただし ANSI 1 バイト文字のみの場合や、
'   UTF-8 ではないマルチバイト文字が 1 文字でも含まれていた場合は
'   False を返しますのでご注意ください。
'
'現バージョンでは UTF-8 として正しい範囲の数値であるか否かで
'判別を行っており、Unicode(UCS-2) にデコードした文字列が
'正しい文字列であるか否かの判別は行っておりませんので、β版です(^^;
'
'この関数の作成には、土田 健一さん作のテキストエディタ JVim の
'judge_jcode 関数を一部参考にさせていただきました。
'
'Ken'ichi Tsuchida Home Page : http://www.st.rim.or.jp/~ken_t/
'
Public Function IsUtf8 _
    (ByRef bytArray() As Byte, _
     Optional ByVal lngReadSize As Long = ISUTF8_DEFAULT_READSIZE, _
     Optional ByVal lngUtf8Count As Long = ISUTF8_DEFAULT_UTF8COUNT, _
     Optional ByVal blnCountStop As Boolean = False, _
     Optional ByVal blnTrustBOM As Boolean = False) As Boolean
 
 Dim lngArraySize As Long                                                                       '配列サイズを格納する変数
 Dim lngReadPosition As Long                                                                    '読み込み位置カウンタ
 Dim lngUtf8ByteSize As Long                                                                    'UTF-8 1 文字のバイト数 - 1 を格納する変数
 Dim lngIsUtf8 As Long                                                                          'UTF-8 確定回数カウンタ
 Dim i As Long                                                                                  'ループカウンタ
 
    If lngReadSize = 0 Then GoTo ExitFunction                                                   '読み込みサイズが 0 の場合、関数を抜ける
    If lngUtf8Count = 0 Then GoTo ExitFunction                                                  '指定確定回数が 0 の場合、関数を抜ける
    On Error GoTo ExitFunction                                                                  'エラーをトラップした場合、関数を抜ける
    lngArraySize = UBound(bytArray) + 1                                                         'bytArray() の配列サイズを得る
    On Error GoTo 0                                                                             'エラートラップを無効にする
    If lngReadSize > lngArraySize Then lngReadSize = lngArraySize                               '読み込みサイズが配列サイズより大きい場合、配列サイズに
    If lngUtf8Count > lngArraySize Then lngUtf8Count = lngArraySize                             '指定確定回数が配列サイズより大きい場合、配列サイズに
    
    If lngArraySize >= 3 Then                                                                   '配列サイズが 3 以上の場合
        If bytArray(0) = &HEF And bytArray(1) = &HBB And bytArray(2) = &HBF Then                'BOM が存在する場合
            If blnTrustBOM Then                                                                 'BOM を無条件で信用する場合
                IsUtf8 = True                                                                   'True を返す
                GoTo ExitFunction                                                               '関数を抜ける
            Else                                                                                'BOM を信用しない場合
                If lngArraySize >= 4 Then                                                       '配列サイズが 4 以上の場合
                    lngReadPosition = 3                                                         '読み込みカウンタを 3 にする
                Else                                                                            'BOM しか存在しない場合
                    GoTo ExitFunction                                                           '関数を抜ける
                End If
            End If
        End If
    End If
        
    Do While lngReadPosition < lngReadSize                                                      '指定サイズ分ループ
        If bytArray(lngReadPosition) <= &H7F Then                                               'ANSI 標準文字だった場合
            lngReadPosition = lngReadPosition + 1                                               '読み込みカウンタをインクリメント
        ElseIf bytArray(lngReadPosition) < &HC0 Then                                            '&HC0 より小さい値の場合(UTF-8 ではない)
            Exit Function                                                                       '関数を抜ける
        ElseIf (bytArray(lngReadPosition) >= &HC0) And (bytArray(lngReadPosition) <= &HFD) Then 'UTF-8 の第 1 バイトらしい場合
            If (bytArray(lngReadPosition) And &HFC) = &HFC Then                                 '上位 6 ビットのフラグが立っている場合
                lngUtf8ByteSize = 5                                                             '次 5 バイトも UTF-8 のバイト列かも
            ElseIf (bytArray(lngReadPosition) And &HF8) = &HF8 Then                             '上位 5 ビットのフラグが立っている場合
                lngUtf8ByteSize = 4                                                             '次 4 バイトも UTF-8 のバイト列かも
            ElseIf (bytArray(lngReadPosition) And &HF0) = &HF0 Then                             '上位 4 ビットのフラグが立っている場合
                lngUtf8ByteSize = 3                                                             '次 3 バイトも UTF-8 のバイト列かも
            ElseIf (bytArray(lngReadPosition) And &HE0) = &HE0 Then                             '上位 3 ビットのフラグが立っている場合
                lngUtf8ByteSize = 2                                                             '次 2 バイトも UTF-8 のバイト列かも
            ElseIf (bytArray(lngReadPosition) And &HC0) = &HC0 Then                             '上位 2 ビットのフラグが立っている場合
                lngUtf8ByteSize = 1                                                             '次 1 バイトも UTF-8 のバイト列かも
            End If
            If (lngReadPosition + lngUtf8ByteSize) >= lngReadSize Then Exit Do                  '配列の終端に達している場合、ループを抜ける
            For i = (lngReadPosition + 1) To (lngReadPosition + lngUtf8ByteSize) Step 1         '第 2 バイト以降からループ
                If Not ((bytArray(i) >= &H80) And (bytArray(i) <= &HBF)) Then Exit Function     'UTF-8 の文字列ではない値の場合、関数を抜ける
            Next i
            lngIsUtf8 = lngIsUtf8 + 1                                                           'UTF-8 確定回数をインクリメント
            lngReadPosition = lngReadPosition + lngUtf8ByteSize + 1                             '次回読み込み位置を設定
        Else                                                                                    'その他の場合(&HFF の場合のみ)
            lngReadPosition = lngReadPosition + 1                                               '読み込みカウンタをインクリメント
        End If
        If blnCountStop Then                                                                    '指定回数ストップフラグが指定されている場合
            If lngIsUtf8 = lngUtf8Count Then Exit Do                                            '指定回数に達した場合、ループを抜ける
        End If
    Loop
    
    If lngIsUtf8 >= lngUtf8Count Then IsUtf8 = True                                             'UTF-8 確定回数が指定回数以上の場合、True を返す
    
ExitFunction:

End Function