MCServer_Protocol/UTF8Code.bas

Attribute VB_Name = "UTF8COde"
Option Explicit

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, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Const CP_UTF8 = 65001
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Function UTF8_Encode(ByVal strUnicode As String) As Byte()
'UTF-8 <20><><EFBFBD><EFBFBD>

    Dim TLen As Long
    Dim lngBufferSize As Long
    Dim lngResult As Long
    Dim bytUtf8() As Byte

    TLen = Len(strUnicode)
    If TLen = 0 Then Exit Function

    lngBufferSize = TLen * 3 + 1
    ReDim bytUtf8(lngBufferSize - 1)

    lngResult = WideCharToMultiByte(CP_UTF8, 0, StrPtr(strUnicode), TLen, bytUtf8(0), lngBufferSize, vbNullString, 0)

    If lngResult <> 0 Then
        lngResult = lngResult - 1
        ReDim Preserve bytUtf8(lngResult)
    End If

    UTF8_Encode = bytUtf8
End Function

Public Function UTF8_Decode(ByRef bUTF8() As Byte) As String
'UTF-8 <20><><EFBFBD><EFBFBD>
    Dim lRet As Long
    Dim lLen As Long
    Dim lBufferSize As Long
    Dim sBuffer As String
    Dim bBuffer() As Byte

    lLen = UBound(bUTF8) + 1

    If lLen = 0 Then Exit Function

    lBufferSize = lLen * 2

    sBuffer = String$(lBufferSize, Chr(0))

    lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(bUTF8(0)), lLen, StrPtr(sBuffer), lBufferSize)

    If lRet <> 0 Then
        sBuffer = Left(sBuffer, lRet)
    End If

    UTF8_Decode = sBuffer
End Function

Public Function CreateStringFromByte(ByRef byteArray() As Byte, ByVal ByteLength As Long) As String
'<27>ֽ<EFBFBD><D6BD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>е<EFBFBD><D0B5><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ӳ<EFBFBD><D3B3>ַ<EFBFBD><D6B7><EFBFBD>

    Dim StringData As String

    '** <20><><EFBFBD><EFBFBD><EFBFBD>ַ<EFBFBD><D6B7><EFBFBD><EFBFBD>ռ<EFBFBD>
    StringData = Space(ByteLength)
    '** <20><><EFBFBD><EFBFBD><EFBFBD>ַ<EFBFBD><D6B7><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ַ<EFBFBD><D6B7><EFBFBD>ݵ<EFBFBD><DDB5>ַ<EFBFBD><D6B7><EFBFBD><EFBFBD><EFBFBD>ַ
    MoveMemory ByVal StringData, ByVal VarPtr(byteArray(0)), ByteLength

    '** <20><><EFBFBD><EFBFBD><EFBFBD>ַ<EFBFBD><D6B7><EFBFBD>
    CreateStringFromByte = StringData
End Function

Public Function SaveStringToByteArry(ByRef strString As String) As Byte()
'<27><><EFBFBD>ַ<EFBFBD><D6B7><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ֽ<EFBFBD><D6BD><EFBFBD><EFBFBD><EFBFBD>

    Dim BytArray() As Byte, lngStrLen As Long

    '** <20><>ȡ<EFBFBD>ַ<EFBFBD><D6B7><EFBFBD><EFBFBD>ij<EFBFBD><C4B3><EFBFBD>(<28>ֽ<EFBFBD>)
    lngStrLen = LenB(StrConv(strString, vbFromUnicode))

    '** <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ռ<EFBFBD>
    ReDim BytArray(lngStrLen - 1)

    '** <20><><EFBFBD>ַ<EFBFBD><D6B7><EFBFBD><EFBFBD><EFBFBD>ַ<EFBFBD>е<EFBFBD><D0B5><EFBFBD><EFBFBD>ݿ<EFBFBD><DDBF><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
    MoveMemory ByVal VarPtr(BytArray(0)), ByVal strString, lngStrLen

    SaveStringToByteArry = BytArray
End Function