дешифровка Unicode

Function ReadAnyTextFile(sFilePath$, Optional fGetRowsArray As Boolean) As Variant
'Функция читает файлы в формате:
' Обычный (ANSI/OEM и т.п. с однобайтовой кодировкой)
' Unicode (UTF-16 LE, UTF-16 BE)
' UTF-8
'Формат файла определяется по маркеру BOM (первые 2-3 байта в начале файла)
' или анализом.
'Лишние завершающие символы vbCr и/или vbLf исключаются.
'Если fGetRowsArray=0, возвращает содержимое файла.
'Если fGetRowsArray=1, возвращает массив строк (разделитель vbCrLf, vbCr или vbLf).
On Error Resume Next
Dim i&, j&, k%, s$, arr() As Byte, iUtf8%, iUtf16%
    
    i = FreeFile: Open sFilePath$ For Binary Access Read Shared As i
 If Err.Number <> 0 Then Err.Clear: Exit Function
    
    j = LOF(i): If j = 0 Then Close i: GoTo Finish
 If j >= 4 Then
    ReDim arr(1 To 4): Get i, , arr
'Проверяется наличие признака кодировки (первые 2-3 байта).
  If arr(1) = &HFF And arr(2) = &HFE And arr(3) <> 0 Then
'Есть признак Unicode(UTF-16 LE). Читаем с 3-го байта.
    k = 2: iUtf16 = 1
  ElseIf arr(1) = &HFE And arr(2) = &HFF And arr(4) <> 0 Then
'Есть признак Unicode(UTF-16 BE). Читаем с 3-го байта.
    k = 2: iUtf16 = 2
  ElseIf arr(1) = &HEF And arr(2) = &HBB And arr(3) = &HBF Then
'Есть признак UTF-8. Читаем с 4-го байта.
    k = 3: iUtf8 = 1
  End If
 End If
    j = j - k: ReDim arr(1 To j): Get i, 1 + k, arr
    Close i

 If iUtf16 = 0 And iUtf8 = 0 And (UBound(arr) Mod 2) = 0 Then
'Проверка Unicode. Контролируется значение старшего байта в первом и последнем символе.
'Этого достаточно, если эти символы не "№" и не специальные знаки
' (например - математические или химические).
  If arr(2) <= 5 And arr(UBound(arr)) <= 5 Then
    iUtf16 = 1
  ElseIf arr(1) <= 5 And arr(UBound(arr) - 1) <= 5 Then
    iUtf16 = 2
  End If
 End If
 If iUtf16 = 2 Then
'Для UTF-16 BE в цикле меняем местами парные байты.
  For i = 1 To j - 1 Step 2
    k = arr(i): arr(i) = arr(i + 1): arr(i + 1) = k
  Next
 End If
 If iUtf16 > 0 Then s = arr: GoTo Finish

'Проверка UTF-8
 For i = 1 To j - 1
  Select Case arr(i)
  Case Is <= 127
  Case &HC2 To &HDF
'В UTF-8 после байта с таким кодом должен стоять байт с кодом &H80-&HBF
   If arr(i + 1) < &H80 Or arr(i + 1) > &HBF Then iUtf8 = 0: Exit For
    iUtf8 = 3: i = i + 1
  Case &HE0 To &HFF
'В UTF-8 после байта с таким кодом должны стоять 2 байта с кодом &H80-&HBF
   If i = j - 1 Then iUtf8 = False: Exit For
   If arr(i + 1) < &H80 Or arr(i + 1) > &HBF Then iUtf8 = 0: Exit For
   If arr(i + 2) < &H80 Or arr(i + 2) > &HBF Then iUtf8 = 0: Exit For
    iUtf8 = 3: i = i + 2
  Case Else
    iUtf8 = 0: Exit For
  End Select
 Next
'Если в массиве найдены недопустимые для UTF-8 коды или все коды <=127
 If iUtf8 < 3 Then s = StrConv(arr, vbUnicode): GoTo Finish

'Преобразование UTF-8 -> Unicode
 For i = 1 To j
'Переменная "k" (код символа) - Integer (2 байта или 16 битов с весом 0-15)
  Select Case arr(i)
  Case Is <= 127
    k = arr(i)
  Case &HC2 To &HDF
'6 младших битов 2-го байта переносятся в код с тем же весом (0-5)
    k = (arr(i + 1) And &H3F)
'5 младших битов 1-го байта переносятся в код с весом 6-10
    k = k + (arr(i) And &H1F) * &H40        'Биты смещаются на 6 позиций влево.
    i = i + 1
  Case &HE0 To &HFF
'6 младших битов 3-го байта переносятся в код с тем же весом (0-5)
    k = (arr(i + 2) And &H3F)
'6 младших битов 2-го байта переносятся в код с весом 6-11
    k = k + (arr(i + 1) And &H1F) * &H40    'Биты смещаются на 6 позиций влево.
'4 младших бита 1-го байта переносятся в код с весом 12-15
    k = k + (arr(i) And &HF) * &H1000       'Биты смещаются на 12 позиций влево.
    i = i + 2
  End Select
  If k <= 127 Then s = s & Chr(k) Else s = s & ChrW(k)
 Next

Finish:
'Исключаются лишние завершающие символы vbCr и/или vbLf
    j = Len(s): Erase arr
 For i = j To 1 Step -1
    k = Asc(Mid$(s, i, 1))
  If k <> 13 And k <> 10 Then Exit For
 Next
 If i < j Then s = Left(s, i)
 
 If Not fGetRowsArray Then ReadAnyTextFile = s: Exit Function
 If i <= 1 Then ReadAnyTextFile = Split(s): Exit Function
'Преобразование текста в массив строк.
 If InStr(s, vbCrLf) > 0 Then
    ReadAnyTextFile = Split(s, vbCrLf)
 ElseIf InStr(s, vbLf) > 0 Then
    ReadAnyTextFile = Split(s, vbLf)
 Else
    ReadAnyTextFile = Split(s, vbCr)
 End If
End Function

Selection.InsertSymbol

Sub s_election()
Dim sText$, iFour&, iThree&, iTwo&, iOne&, iTenCodeSystem&
'Перевод Unicode из шестнадцатеричной системы в десятичную
sText = Selection.Range.Text
iOne = Замещение(Right(sText, 1))
iTwo = Замещение(Left(Right(sText, 2), 1))
iThree = Замещение(Right(Left(sText, 2), 1))
iFour = Замещение(Left(sText, 1))
iTenCodeSystem = (iOne * 1) + (iTwo * 16) + (iThree * 256) + (iFour * 4096)
sChar = ChrW(iTenCodeSystem)
Selection.Collapse direction:=wdCollapseEnd
Selection.InsertAfter ("-")
Selection.InsertSymbol Font:="TimesNewRoman", CharacterNumber:=iTenCodeSystem, Unicode:=True
End Sub
Private Function Замещение(ByVal InputText As String)
If IsNumeric(InputText) Then Замещение = CInt(InputText): GoTo LineOut
If InputText Like "[a-f]" Then
    Замещение = CInt(Replace(Replace(Replace(Replace(Replace(Replace(InputText, "a", "10"), "b", "11"), "c", "12"), "d", "13"), "e", "14"), "f", "15"))
ElseIf InputText Like "[A-F]" Then
    Замещение = CInt(Replace(Replace(Replace(Replace(Replace(Replace(InputText, "A", "10"), "B", "11"), "C", "12"), "D", "13"), "E", "14"), "F", "15"))
End If
LineOut:
End Function

Sub Uni_To_Char()
Dim oRng As Range
    Set oRng = ActiveDocument.Content
    ResetFRParameters oRng 
    With oRng.Find
        .Text = "\\u[0-9A-Fa-f]{4}"
        .Forward = True
        .MatchWildcards = True
        While .Execute
            With oRng
                .End = .Start + 2
                .Text = ""
                .End = .Start + 4
                .Select
                Selection.ToggleCharacterCode 'ALT+X на клавиатуре
                .Collapse wdCollapseEnd
            End With
        Wend
  End With
End Sub

Sub ResetFRParameters(oRng As Range)
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
End Sub