Question

求一个VB6（XP系统）将服务器传回的UTF-8编码转换为ansi的完美代码

vb6（XP系统下）使用winsock向web服务器发送url
返回的是utf-8的数据，使用网上常见的utf-8转ansi的代码不能完美转换，总是有一些字符会变成“?”，往往都是在后面跟着一个ansi字符的时候发生
请问如何解决？

Public Declare Function WideCharToMultiByte Lib "kernel32 " (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Public Declare Function MultiByteToWideChar Lib "kernel32 " (ByVal CodePage As Long, ByVal dwFlags As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory " (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Public Function UTF8_Decode(ByVal sUTF8 As String) As String
Dim lngUtf8Size As Long
Dim strBuffer As String
Dim lngBufferSize As Long
Dim lngResult As Long
Dim bytUtf8() As Byte
Dim n As Long
Dim i As Long
Dim TopIndex As Long
Dim TwoBytes(1) As Byte
Dim ThreeBytes(2) As Byte
Dim AByte As Byte
Dim TStr As String
Dim BArray() As Byte
If LenB(sUTF8) = 0 Then Exit Function
'Resume on error in case someone inputs text with accents
'that should have been encoded as UTF-8
On Error Resume Next

TopIndex = Len(sUTF8) ' Number of bytes equal TopIndex+1
If TopIndex = 0 Then Exit Function ' get out if there 's nothing to convert
BArray = StrConv(sUTF8, vbFromUnicode)

i = 0 ' Initialise pointer
TopIndex = TopIndex - 1
' Iterate through the Byte Array
Do While i <= TopIndex
AByte = BArray(i)
If AByte < &H80 Then
' Normal ANSI character - use it as is
TStr = TStr & Chr$(AByte): i = i + 1 ' Increment byte array index
ElseIf AByte >= &HE0 Then 'was = &HE1 Then
' Start of 3 byte UTF-8 group for a character
' Copy 3 byte to ThreeBytes
ThreeBytes(0) = BArray(i): i = i + 1
ThreeBytes(1) = BArray(i): i = i + 1
ThreeBytes(2) = BArray(i): i = i + 1
' Convert Byte array to UTF-16 then Unicode
TStr = TStr & ChrW$((ThreeBytes(0) And &HF) * &H1000 + (ThreeBytes(1) And &H3F) * &H40 + (ThreeBytes(2) And &H3F))
ElseIf (AByte >= &HC2) And (AByte <= &HDB) Then
' Start of 2 byte UTF-8 group for a character
TwoBytes(0) = BArray(i): i = i + 1
TwoBytes(1) = BArray(i): i = i + 1
Convert Byte array to UTF-16 then Unicode
TStr = TStr & ChrW$((TwoBytes(0) And &H1F) * &H40 + (TwoBytes(1) And &H3F))
Else
' Normal ANSI character - use it as is
TStr = TStr & Chr$(AByte): i = i + 1 ' Increment byte array index
End If
Loop
UTF8_Decode = TStr ' Return the resultant string
Erase BArray
EndFunction:

End Function
tiancao1001 朋友的UTF8_to_Unicode函数没有看到，无法运行
ljl88900 朋友的代码好像有问题，之前我看过一个据说是外国人写的转换代码，其中根据是否NT操作系统有两种转换方式， 看起来就好像不是XP系统下的那种转换。转换后多了很多空格，而且字符全部都是乱码
能否请两位重新查看一下？

Answer 1

'问题出在 BArray = StrConv(sUTF8, vbFromUnicode) 这句。因为下载的是UTF-8编码,经过此转换后反而会出现很多问题，所以应该直接对下载的字符串进行处理即可。

根据你的来信，现把完整代码列示如下（根据是否NT操作系统有两种转换方式）：
（把下面代码复制到模块中）
Option Explicit

'Utf8字符转化成Unicode字符定义
Private origWndProc As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Const CP_UTF8 = 65001
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'获得系统的类型定义
Private Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type

'获得系统的类型
Public Function GetVersion() As String
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer

osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionExA(osinfo)

With osinfo
Select Case .dwPlatformId
Case 1
Select Case .dwMinorVersion
Case 0
GetVersion = "1Windows 95"
Case 10
GetVersion = "1Windows 98"
Case 90
GetVersion = "1Windows Mellinnium"
End Select
Case 2
Select Case .dwMajorVersion
Case 3
GetVersion = "2Windows NT 3.51"
Case 4
GetVersion = "2Windows NT 4.0"
Case 5
If .dwMinorVersion = 0 Then
GetVersion = "2Windows 2000"
Else
GetVersion = "2Windows XP"
End If
End Select
Case Else
GetVersion = "Failed"
End Select
End With
End Function

'功能: 把Utf8字符转化成Unicode字符
Public Function UTF8_Decode(ByVal sUTF8 As String) As String
Dim lngUtf8Size As Long
Dim strBuffer As String
Dim lngBufferSize As Long
Dim lngResult As Long
Dim bytUtf8() As Byte
Dim n As Long
If LenB(sUTF8) = 0 Then Exit Function
If Left(GetVersion(), 1) = "2" Then
On Error GoTo EndFunction
'bytUtf8 = StrConv(sUTF8, vbFromUnicode)
bytUtf8 = sUTF8
lngUtf8Size = UBound(bytUtf8) + 1
On Error GoTo 0
'Set buffer for longest possible string i.e. each byte is
'ANSI, thus 1 unicode(2 bytes)for every utf-8 character.
lngBufferSize = lngUtf8Size * 2
strBuffer = String$(lngBufferSize, vbNullChar)
'Translate using code page 65001(UTF-8)
lngResult = MultiByteToWideChar(CP_UTF8, 0, bytUtf8(0), _
lngUtf8Size, StrPtr(strBuffer), lngBufferSize)
'Trim result to actual length
If lngResult Then
UTF8_Decode = Left(strBuffer, lngResult)
End If
Else
Dim i As Long
Dim TopIndex As Long
Dim TwoBytes(1) As Byte
Dim ThreeBytes(2) As Byte
Dim AByte As Byte
Dim TStr As String
Dim BArray() As Byte

'Resume on error in case someone inputs text with accents
'that should have been encoded as UTF-8
On Error Resume Next

TopIndex = LenB(sUTF8) ' Number of bytes equal TopIndex+1
If TopIndex = 0 Then Exit Function ' get out if there's nothing to convert
'BArray = StrConv(sUTF8, vbFromUnicode)
BArray = sUTF8
i = 0 ' Initialise pointer
TopIndex = TopIndex - 1
' Iterate through the Byte Array
Do While i <= TopIndex
AByte = BArray(i)
If AByte < &H80 Then
' Normal ANSI character - use it as is
TStr = TStr & Chr$(AByte): i = i + 1 ' Increment byte array index
ElseIf AByte >= &HE0 Then 'was = &HE1 Then
' Start of 3 byte UTF-8 group for a character
' Copy 3 byte to ThreeBytes
ThreeBytes(0) = BArray(i): i = i + 1
ThreeBytes(1) = BArray(i): i = i + 1
ThreeBytes(2) = BArray(i): i = i + 1
' Convert Byte array to UTF-16 then Unicode
TStr = TStr & ChrW$((ThreeBytes(0) And &HF) * &H1000 + (ThreeBytes(1) And &H3F) * &H40 + (ThreeBytes(2) And &H3F))
ElseIf (AByte >= &HC2) And (AByte <= &HDB) Then
' Start of 2 byte UTF-8 group for a character
TwoBytes(0) = BArray(i): i = i + 1
TwoBytes(1) = BArray(i): i = i + 1
' Convert Byte array to UTF-16 then Unicode
TStr = TStr & ChrW$((TwoBytes(0) And &H1F) * &H40 + (TwoBytes(1) And &H3F))
Else
' Normal ANSI character - use it as is
TStr = TStr & Chr$(AByte): i = i + 1 ' Increment byte array index
End If
Loop
UTF8_Decode = TStr ' Return the resultant string
Erase BArray
End If

EndFunction:

End Function

Answer 2

给你一个字节转unicode
Function Bytes_to_Unicode(Bytes, CodeType As String)
Dim strReturn As String
Dim i As Long
Dim ThisCharCode As Integer
Dim NextCharCode As Integer
Dim ThirdCharCode As Integer
strReturn = ""
For i = 1 To LenB(Bytes)
ThisCharCode = AscB(MidB(Bytes, i, 1))
If ThisCharCode < &H80 Then
strReturn = strReturn & Chr(ThisCharCode)
Else
If CodeType = "UTF-8" Or CodeType = "UTF8" Then
NextCharCode = AscB(MidB(Bytes, i + 1, 1))
ThirdCharCode = AscB(MidB(Bytes, i + 2, 1))
strReturn = strReturn & UTF8_to_Unicode(ThisCharCode, NextCharCode, ThirdCharCode)
i = i + 2
Else
NextCharCode = AscB(MidB(Bytes, i + 1, 1))
strReturn = strReturn & Unicode(ThisCharCode, NextCharCode)
i = i + 1
End If
End If
Next
Bytes_to_Unicode = strReturn
End Function

Answer 3

5545544578487654988796641152455855878976916594845619875641454144541445414414hgcgcdfbcxssddccxsxxzxz