Получить символы Юникода со значениями charcode больше шестнадцатеричного `FFFF`

Question

Issue

Аргумент ChrW charcode - это Long, который идентифицирует символ, но не допускает значений, превышающих 65535 (шестнадцатеричное значение &HFFFF) - см Справка MS .

Например, Различные символы и пиктограммы можно найти в Шестнадцатеричный блок Unicode 1F300-1F5FF. Поэтому я не нашел каким-либо образом для представления предложенных шестнадцатеричных значений ► 1F512 и 1F513 для открытого или закрытого символа замка именно в этот блок кодов , как и в случае курса ChrW(&H1F512), приведет к неправильному вызову процедуры / аргумента.

Недавний ответ нашел возможно ошибочную альтернативу, ссылающуюся на нижний кодовый код (через ChrW(&HE1F7) и ChrW(&HE1F6)), но я ищу способ получить более высокое представление кодов.

Вопрос

Существует ли систематический способ выражения символов Юникода , найденных в блоках шестнадцатеричного кода, больших чем FFFF, с помощью VBA или обходного решения?

Answer 1

Нечто подобное должно работать.Большую часть кода я не писал, но я знал, что искать.По сути, сопоставьте Hex эквиваленту байтового массива, затем верните строку.

 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 https://stackoverflow.com/questions/28798759/how-convert-hex-string-into-byte-array-in-vb6
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), равна 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

Answer 3

как альтернатива Т.М ..

Не забудьте добавить ссылку на «Библиотеку объектов Microsoft HTML»

Function GetUnicode(CharCodeString As String) As String
    Dim Doc As New HTMLDocument
    Doc.body.innerHTML = "&#x" & CharCodeString & ";"
    GetUnicode = Doc.body.innerText
End Function

Answer 4

Ниже приведен код VBScript, который я использую в ASP Classic.

Как вы заметите, здесь нет объявлений типов, все варианты. То, что я намеревался сделать с этим, имело функции ChrU и AscU, поддерживающие символы вне UCS-2 (Базовая многоязычная плоскость).

Поскольку это написано в первую очередь для VBScript, я думаю, что он не зависит от хоста. У меня его нет, но он должен работать и на MAC. Надеюсь, это поможет.

Private Function RightShift(ByVal pVal, shift)
    Dim i, nVal
    For i = 1 To shift
        nVal = (pVal And &H7FFFFFFF) \ 2
        If nVal And &H80000000 Then nVal = nVal Or &HC0000000
        pVal = nVal
    Next
    RightShift = pVal
End Function

Private Function LeftShift(ByVal pVal, shift)
    Dim i, nVal
    For i = 1 To shift
        nVal = (pVal And &H3FFFFFFF) * 2
        If pVal And &H40000000 Then
            nVal = nVal Or &H80000000
        End If
        pVal = nVal
    Next
    LeftShift = nVal
End Function

Public Function ChrU(ByVal code)
    Dim lo, hi ' to hold 16-bit surrogate pairs

    code = Int(code)
    If code <= 65535 Then
        ' code is in the UCS-2 range (a.k.a. Basic Multilingual Plane) which ChrW (and AscW) relies on.
        ' falling back to ChrW
        ChrU = ChrW(code)
    ElseIf code <= 1114111 Then ' code is in the Unicode range beyond UCS-2
        code = code - &H10000
        lo = ChrW(&HD800& Or RightShift(code, 10))
        hi = ChrW(&HDC00& Or (code And &H3FF))
        ChrU = Join(Array(lo, hi), "")
    Else
        Err.Raise 9, "ChrU", "Code point was out of range."
    End If
End Function

Public Function AscU(str)
    Dim lo, hi ' to hold 16-bit surrogate pairs

    If Len(str) = 1 Then
        AscU = AscW(str) And &HFFFF&
    Else
        Dim txt

        txt = Left(str, 2)
        lo = AscW(Mid(txt, 1, 1)) And &HFFFF&
        hi = AscW(Mid(txt, 2, 1)) And &HFFFF&

        If &HDC00& > hi Or hi > &HDFFF& Then
            ' hi surrogate is not valid
            ' assuming "str" is a Unicode (UCS-2) string of at least 2 characters
            ' returning first character's codepoint
            ' as Asc and AscW do
            AscU = lo
            Exit Function
        End If

        AscU = &H10000 + LeftShift(lo And &H3FF, 10) + (hi And &H3FF)
    End If
End Function

Answer 5

Обойти через HTML

Просто в дополнение к действующим решениям, приведенным выше: я нашел легкий способ использования IE HTML контента, так как HTML не различает младшие и старшие наборы блоков кода; функция ниже просто возвращает интерпретированный внутренний html :

Пример вызова написания символа замка, например на ячейку A1

[A1] = GetUnicode("1F512")

[1] Функция GetUnicode () - через InternetExplorer

Function GetUnicode$(ByVal CharCodeString$)
' Purpose: get Unicode character via any valid unprefixed hex code string
' Note:    late bound InternetExplorer reference
Dim Ie As Object
Set Ie = CreateObject("InternetExplorer.Application")
With Ie
    .Visible = False
    .Navigate "about:blank"
    .document.body.innerhtml = "&#x" & CharCodeString & ";"  ' prefixing HTML code
    GetUnicode = .document.body.innerhtml
   .Quit
End With
End Function

[2] Альтернативная функция GetUnicode () - через XMLDom (Изменить 5/12 2019)

Это представляет собой независимый от хоста подход, использующий XMLDom. Ссылаясь Википедия

«Объектная модель документа (DOM) - это межплатформенный и независимый от языка интерфейс прикладного программирования, который обрабатывает XML-документ как древовидную структуру, в которой каждый узел является объектом, представляющим часть документа.»

Подобно подходу IE, объект Unicode состоит из числового (шестнадцатеричного) префикса &#x + num + ;. Обычно я люблю XML, поскольку он позволяет более гибкое кодирование с помощью ссылок на отдельные узлы и подузлы; этот пример только демонстрирует самый простой способ дать идею.

Function getUnicode$(ByVal CharCodeString$)
' Purpose: get Unicode character via any valid unprefixed hex code string
' Note:    late bound MSXML2 reference using XMLDom
Dim XmlString$
XmlString = "<?xml version=""1.0"" encoding=""UTF-8""?><root><symbol>&#x" _
    & CharCodeString & ";</symbol></root>"
With CreateObject("MSXML2.DOMDocument.6.0")
    .ValidateOnParse = True
    .Async = False
    If .LoadXML(XmlString) Then
        getUnicode = .DocumentElement.SelectSingleNode("symbol").Text
    End If
End With
End Function