VB6的UTF8编码解码

'UTF-8编码

 Public Function UTF8Encode(ByVal szInput As String) As String

    Dim wch  As String

    Dim uch As String

    Dim szRet As String

    Dim x As Long

    Dim inputLen As Long

    Dim nAsc  As Long

    Dim nAsc2 As Long

    Dim nAsc3 As Long

     

    If szInput = "" Then

        UTF8Encode = szInput

        Exit Function

    End If

    inputLen = Len(szInput)

    For x = 1 To inputLen

    '得到每个字符

        wch = Mid(szInput, x, 1)

        '得到相应的UNICODE编码

        nAsc = AscW(wch)

    '对于<0的编码　其需要加上65536

        If nAsc < 0 Then nAsc = nAsc + 65536

    '对于<128位的ASCII的编码则无需更改

        If (nAsc And &HFF80) = 0 Then

            szRet = szRet & wch

        Else

            If (nAsc And &HF000) = 0 Then

            '真正的第二层编码范围为000080 - 0007FF

            'Unicode在范围D800-DFFF中不存在任何字符，基本多文种平面中约定了这个范围用于UTF-16扩展标识辅助平面（两个UTF-16表示一个辅助平面字符）.

            '当然，任何编码都是可以被转换到这个范围，但在unicode中他们并不代表任何合法的值。

     

                uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)

                szRet = szRet & uch

                 

            Else

            '第三层编码00000800 – 0000FFFF

            '首先取其前四位与11100000进行或去处得到UTF-8编码的前8位

            '其次取其前10位与111111进行并运算，这样就能得到其前10中最后6位的真正的编码　再与10000000进行或运算来得到UTF-8编码中间的8位

            '最后将其与111111进行并运算，这样就能得到其最后6位的真正的编码　再与10000000进行或运算来得到UTF-8编码最后8位编码

                uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _

                Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _

                Hex(nAsc And &H3F Or &H80)

                szRet = szRet & uch

            End If

        End If

    Next

     

    UTF8Encode = szRet

End Function

 

 

'UTF-8解码(2-25更改,采用递归方法，可以对一串字符串解码,仅仅为演示此算法,请不要随意调用)

 

'形式类如department=%E4%B9%B3%E8%85%BA'%E5%A4%96%E7%A7%91

Public Function UTF8BadDecode(ByVal code As String) As String

    If code = "" Then

        Exit Function

    End If

    

    Dim tmp As String

    Dim decodeStr As String

    Dim codelen As Long

    Dim result As String

    Dim leftStr As String

    

    leftStr = Left(code, 1)

    

    If leftStr = "" Then

    

        UTF8BadDecode = ""

        Exit Function

        

    ElseIf leftStr <> "%" Then

    

        UTF8BadDecode = leftStr + UTF8BadDecode(Right(code, Len(code) - 1))

        

    ElseIf leftStr = "%" Then

    

        codelen = Len(code)

        

        If (Mid(code, 2, 1) = "C" Or Mid(code, 2, 1) = "B") Then

            decodeStr = Replace(Mid(code, 1, 6), "%", "")

            tmp = c10ton(Val("&H" & Hex(Val("&H" & decodeStr) And &H1F3F)))

            tmp = String(16 - Len(tmp), "0") & tmp

            UTF8BadDecode = UTF8BadDecode & ChrW(Val("&H" & c2to16(Mid(tmp, 3, 4)) & c2to16(Mid(tmp, 7, 2) & Mid(tmp, 11, 2)) & Right(decodeStr, 1))) & UTF8BadDecode(Right(code, codelen - 6))

        ElseIf (Mid(code, 2, 1) = "E") Then

            decodeStr = Replace(Mid(code, 1, 9), "%", "")

            tmp = c10ton((Val("&H" & Mid(Hex(Val("&H" & decodeStr) And &HF3F3F), 2, 3))))

            tmp = String(10 - Len(tmp), "0") & tmp

            UTF8BadDecode = ChrW(Val("&H" & (Mid(decodeStr, 2, 1) & c2to16(Mid(tmp, 1, 4)) & c2to16(Mid(tmp, 5, 2) & Right(tmp, 2)) & Right(decodeStr, 1)))) & UTF8BadDecode(Right(code, codelen - 9))

        Else

            UTF8BadDecode = Chr(Val("&H" & (Mid(code, 2, 2)))) & UTF8BadDecode(Right(code, codelen - 3))

        End If

        

    End If

End Function

 

 

'UTF-8解码(3-12更改,可以解多个字符串 可供正常使用)

 

Public Function UTF8Decode(ByVal code As String) As String

    If code = "" Then

        UTF8Decode = ""

        Exit Function

    End If

    

    Dim tmp As String

    Dim decodeStr As String

    Dim codelen As Long

    Dim result As String

    Dim leftStr As String

     

    leftStr = Left(code, 1)

     

    While (code <> "")

        codelen = Len(code)

        leftStr = Left(code, 1)

        If leftStr = "%" Then

                If (Mid(code, 2, 1) = "C" Or Mid(code, 2, 1) = "B") Then

                    decodeStr = Replace(Mid(code, 1, 6), "%", "")

                    tmp = c10ton(Val("&H" & Hex(Val("&H" & decodeStr) And &H1F3F)))

                    tmp = String(16 - Len(tmp), "0") & tmp

                    UTF8Decode = UTF8Decode & UTF8Decode & ChrW(Val("&H" & c2to16(Mid(tmp, 3, 4)) & c2to16(Mid(tmp, 7, 2) & Mid(tmp, 11, 2)) & Right(decodeStr, 1)))

                    code = Right(code, codelen - 6)

                ElseIf (Mid(code, 2, 1) = "E") Then

                    decodeStr = Replace(Mid(code, 1, 9), "%", "")

                    tmp = c10ton((Val("&H" & Mid(Hex(Val("&H" & decodeStr) And &HF3F3F), 2, 3))))

                    tmp = String(10 - Len(tmp), "0") & tmp

                    UTF8Decode = UTF8Decode & ChrW(Val("&H" & (Mid(decodeStr, 2, 1) & c2to16(Mid(tmp, 1, 4)) & c2to16(Mid(tmp, 5, 2) & Right(tmp, 2)) & Right(decodeStr, 1))))

                    code = Right(code, codelen - 9)

                End If

        Else

            UTF8Decode = UTF8Decode & leftStr

            code = Right(code, codelen - 1)

        End If

    Wend

End Function

 

'gb2312编码

Public Function GBKEncode(szInput) As String

    Dim i As Long

    Dim startIndex As Long

    Dim endIndex As Long

    Dim x() As Byte

     

    x = StrConv(szInput, vbFromUnicode)

     

    startIndex = LBound(x)

    endIndex = UBound(x)

    For i = startIndex To endIndex

        GBKEncode = GBKEncode & "%" & Hex(x(i))

    Next

End Function

 

'GB2312编码

Public Function GBKDecode(ByVal code As String) As String

    code = Replace(code, "%", "")

    Dim bytes(1) As Byte

    Dim index As Long

    Dim length As Long

    Dim codelen As Long

    codelen = Len(code)

    While (codelen > 3)

        For index = 1 To 2

            bytes(index - 1) = Val("&H" & Mid(code, index * 2 - 1, 2))

        Next index

        GBKDecode = GBKDecode & StrConv(bytes, vbUnicode)

        code = Right(code, codelen - 4)

        codelen = Len(code)

    Wend

End Function

 

'二进制代码转换为十六进制代码

Public Function c2to16(ByVal x As String) As String

   Dim i As Long

   i = 1

   For i = 1 To Len(x) Step 4

      c2to16 = c2to16 & Hex(c2to10(Mid(x, i, 4)))

   Next

End Function

 

'二进制代码转换为十进制代码

Public Function c2to10(ByVal x As String) As String

   c2to10 = 0

   If x = "0" Then Exit Function

   Dim i As Long

   i = 0

   For i = 0 To Len(x) - 1

      If Mid(x, Len(x) - i, 1) = "1" Then c2to10 = c2to10 + 2 ^ (i)

   Next

End Function

 

'10进制转n进制(默认2)

Public Function c10ton(ByVal x As Integer, Optional ByVal n As Integer = 2) As String

    Dim i As Integer

    i = x \ n

    If i > 0 Then

        If x Mod n > 10 Then

            c10ton = c10ton(i, n) + chr(x Mod n + 55)

        Else

            c10ton = c10ton(i, n) + CStr(x Mod n)

        End If

    Else

        If x > 10 Then

            c10ton = chr(x + 55)

        Else

            c10ton = CStr(x)

        End If

    End If

End Function