'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