获取字符值大于十六进制FFFF的Unicode字符

Question

问题

该ChrW则charCode参数是一个Long标识字符，但不允许值大于65535（十六进制值&HFFFF） -见MS帮助。

例如，可以在Unicode十六进制块中 找到其他符号和象形文字1F300-1F5FF。因此，我找不到任何方法来表示建议的十六进制值？1F512而1F513对于 恰好在此charcode块中的打开或关闭的挂锁符号，从当然开始，将导致无效的过程/参数调用。ChrW(&H1F512)

最近的答案找到了一个较低的字符码 （通过ChrW(&HE1F7)和ChrW(&HE1F6)）的可能不稳定的选择，但是我正在寻找一种方法来获取较高的字符码表示形式。

题

有没有一种系统的方法来表达在十六进制代码块中找到的Unicode字符，而不是FFFF通过VBA或其他方法来解决？

Answer 1

这样的事情应该起作用。大多数代码我都没有写，但是我知道要寻找什么。基本上将十六进制映射到等效的字节数组，然后返回字符串。

 Option Explicit

'Pulled from https://www.di-mgt.com.au/howto-convert-vba-unicode-to-utf8.html
''' Maps a character string to a UTF-16 (wide character) string
Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpMultiByteStr As LongPtr, _
ByVal cchMultiByte As Long, _
ByVal lpWideCharStr As LongPtr, _
ByVal cchWideChar As Long _
) As Long

' CodePage constant for UTF-8
Private Const CP_UTF8 = 65001

''' Return length of byte array or zero if uninitialized
Private Function BytesLength(abBytes() As Byte) As Long
    ' Trap error if array is uninitialized
    On Error Resume Next
    BytesLength = UBound(abBytes) - LBound(abBytes) + 1
End Function

''' Return VBA "Unicode" string from byte array encoded in UTF-8
Public Function Utf8BytesToString(abUtf8Array() As Byte) As String
    Dim nBytes As Long
    Dim nChars As Long
    Dim strOut As String
    Utf8BytesToString = ""
    ' Catch uninitialized input array
    nBytes = BytesLength(abUtf8Array)
    If nBytes <= 0 Then Exit Function
    ' Get number of characters in output string
    nChars = MultiByteToWideChar(CP_UTF8, 0&, VarPtr(abUtf8Array(0)), nBytes, 0&, 0&)
    ' Dimension output buffer to receive string
    strOut = String(nChars, 0)
    nChars = MultiByteToWideChar(CP_UTF8, 0&, VarPtr(abUtf8Array(0)), nBytes, StrPtr(strOut), nChars)
    Utf8BytesToString = Left$(strOut, nChars)
End Function

'Grabbed from /sf/ask/2015913161/
Private Function HexToBytes(ByVal HexString As String) As Byte()
    'Quick and dirty hex String to Byte array.  Accepts:
    '
    '   "HH HH HH"
    '   "HHHHHH"
    '   "H HH H"
    '   "HH,HH,     HH" and so on.

    Dim Bytes() As Byte
    Dim HexPos As Integer
    Dim HexDigit As Integer
    Dim BytePos As Integer
    Dim Digits As Integer

    ReDim Bytes(Len(HexString) \ 2)  'Initial estimate.
    For HexPos = 1 To Len(HexString)
        HexDigit = InStr("0123456789ABCDEF", _
                         UCase$(Mid$(HexString, HexPos, 1))) - 1
        If HexDigit >= 0 Then
            If BytePos > UBound(Bytes) Then
                'Add some room, we'll add room for 4 more to decrease
                'how often we end up doing this expensive step:
                ReDim Preserve Bytes(UBound(Bytes) + 4)
            End If
            Bytes(BytePos) = Bytes(BytePos) * &H10 + HexDigit
            Digits = Digits + 1
        End If
        If Digits = 2 Or HexDigit < 0 Then
            If Digits > 0 Then BytePos = BytePos + 1
            Digits = 0
        End If
    Next
    If Digits = 0 Then BytePos = BytePos - 1
    If BytePos < 0 Then
        Bytes = "" 'Empty.
    Else
        ReDim Preserve Bytes(BytePos)
    End If
    HexToBytes = Bytes
End Function

呼叫范例

Public Sub ExampleLock()
    Dim LockBytes()  As Byte
    LockBytes = HexToBytes("F0 9F 94 92") ' Lock Hex representation, found by -->http://www.ltg.ed.ac.uk/~richard/utf-8.cgi
    Sheets(1).Range("A1").Value = Utf8BytesToString(LockBytes) ' Output
End Sub

这是输出到A1的内容。

Answer 2

适用于基本多语言平面（BMP）之外的Unicode字符的功能是WorksheetFunction.Unichar()。本示例将包含十六进制的单元格转换为其等效的Unicode：

Sub Convert()
    For i = 1 To Selection.Cells.Count
        n = WorksheetFunction.Hex2Dec(Selection.Cells(i).Text)
        Selection.Cells(i) = WorksheetFunction.Unichar(n)
    Next
End Sub

运行宏之前的原始选择：

运行宏后：

如果您的Excel较旧WorksheetFunction且不可用，则手动构建UTF-16替代品也可以：

Sub Convert()
    For i = 1 To Selection.Cells.Count
        n = CLng("&H" + Selection.Cells(i).Text) 'Convert hexadecimal text to integer
        If n < &H10000 Then 'BMP characters
            Selection.Cells(i) = ChrW(n)
        Else
            'UTF-16 hi/lo surrogate conversion
            'Algorithm:
            '1. Code point - 10000h (max U+10FFFF give 9FFFF...20 bits)
            '2. In binary, but 10 bits in first surrogate (x) and 10 in 2nd surrogate (y)
            '   110110xxxxxxxxxx 110111yyyyyyyyyy
            tmp = n - &H10000
            h = &HD800 + Int(tmp / (2 ^ 10)) 'bitwise right shift by 10
            l = &HDC00 + (tmp And &H3FF)     'bitwise AND of last 10 bits
            Selection.Cells(i) = ChrW(h) + ChrW(l)
        End If
    Next
End Sub