Excel for Microsoft 365 VBA Win32Apiとスピルを使いすべての文字のUTF-16 UTF-8 SJisの文字コードを取得する

http://rocketeer.dip.jp/secProg/unicodebug007.pdf
ここにあった関数がヒントになりました。

Byte配列とWin32APIとスピル機能を使います

サンプルの文字はつちよし𠮷を使います

VBAで Windows APIを使った UTF-8 ←→Unicode相互変換
こちらをお借りします。
次に、シートにつちよしを入力します。
これは次のSheetMake2でできます。

GoToSpillを起動してください

Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32.dll" ( _
    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

Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32.dll" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As LongPtr, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As LongPtr, _
    ByVal cchMultiByte As Long, _
    ByVal lpDefaultChar As LongPtr, _
    ByVal lpUsedDefaultChar As Long) As Long
Private Const CP_UTF8 = 65001
Private Const ERROR_INSUFFICIENT_BUFFER = 122&
Function ToUTF8(ByRef sData As String) As Byte()
    If Len(sData) = 0 Then
        ToUTF8 = ""
        Exit Function
    End If
    Dim nBufferSize As Long
    nBufferSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sData), Len(sData), 0, 0, 0, 0)
    Dim Ret() As Byte
    ReDim Ret(0 To nBufferSize - 1)
    WideCharToMultiByte CP_UTF8, 0, StrPtr(sData), Len(sData), VarPtr(Ret(0)), nBufferSize, 0, 0
    ToUTF8 = Ret
End Function
Sub SheetMake2()
    Worksheets.Add After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    Range("A2").Select
    ActiveCell.FormulaR1C1 = ChrW(&HD842) & ChrW(&HDFB7)
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "=DEC2HEX(R[1]C,2)"
    Range("B1").Select
    Selection.Copy
    Range("C1").Select
    ActiveSheet.Paste
    Range("D1").Select
    ActiveSheet.Paste
    Range("E1").Select
    ActiveSheet.Paste
End Sub
Sub GoToSpill()
    Range("B2").Select
    Application.CutCopyMode = False
    ActiveCell.Formula2R1C1 = "=ToUTF8(RC[-1])"
End Sub
Function VBAAscW(s As String)
VBAAscW = AscW(s)
End Function

また、別の標準モジュールを挿入し、つちよしのサロゲートペアを求めるコードを作ります。
こちらもWinApiを使います。
これはセルに入力したつちよしのChrWの組み合わせを求めることができるようになります。
VBEでは確認できないのでWin32APIのMessageBoxExを使います。

#If VBA7 Then
Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxW" _
    (ByVal hwnd As LongPtr, ByVal lpText As LongPtr, _
     ByVal lpCaption As LongPtr, ByVal wType As Long) As Long
Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
Declare PtrSafe Function GetWindowsDirectory Lib "Kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
 Declare PtrSafe Function GetSystemDirectory Lib "Kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
 Declare PtrSafe Function GetTempPath Lib "Kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'Private Declare PtrSafe Function SetCurrentDirectory Lib "kernel32" (ByVal lpPathName As Long) As Long
' Set rrent Directory
Private Declare PtrSafe Function SetCurrentDirectory Lib "Kernel32" Alias _
                            "SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long
'Private Declare PtrSafe Function SetCurrentDirectory Lib "kernel32.dll" Alias "SetCurrentDirectoryW" (ByVal lpPathName As Long) As Long
'Private Declare PtrSafe Function SetCurrentDirectory Lib "kernel32.dll" Alias "SetCurrentDirectoryA" (ByVal lpPathName As Long) As Long

#Else
'標準モジュールに以下のDeclare ステートメントを追加
Declare Function MessageBox Lib "user32" Alias "MessageBoxW" _
    (ByVal hwnd As Long, ByVal lpText As Long, _
     ByVal lpCaption As Long, ByVal wType As Long) As Long
Declare Function GetFocus Lib "user32" () As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" _
 Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, _
 ByVal nSize As Long) As Long
 #End If
'UFT-16LE SarrogatePairのコード
Sub TestSarrogatePair()
' For Excel
' ActiveCellにサロゲートペア文字が1字入っているとして、
' その上位サロゲートと下位サロゲートを求めて、試験のために
' MsgBoxExで表示する
' このため、Windows APIを使用する
' UTF-16 LE , BEなら bb(0) bb(1) bb(2) bb(3)になる
Dim b As String
Dim bb() As Byte
Dim Text As String
b = ActiveCell.Value
bb = b
Debug.Print "AscW Result(Dec -> Hex)" & vbTab & Hex(AscW(b))
Debug.Print "&H" & Hex(bb(1)) & Hex(bb(0))
Debug.Print "&H" & Hex(bb(3)) & Hex(bb(2))
Text = ChrW("&H" & Hex(bb(1)) & Hex(bb(0))) & ChrW("&H" & Hex(bb(3)) & Hex(bb(2)))
Debug.Print "ChrW(" & "&H" & Hex(bb(1)) & Hex(bb(0)) & ") & ChrW(&H" & Hex(bb(3)) & Hex(bb(2)) & ")"
MsgBoxEx Text
End Sub
'UTF-16 LE
Function UTF16Sarrogate(s As String)
Dim bb() As Byte
If IsUpperSarrogateCharacter(s) And IsLowerSarrogateCharcter(s) Then
bb = s
UTF16Sarrogate = "0x" & CStr(Hex(bb(1)) & Hex(bb(0))) & " " & "0x" & CStr(Hex(bb(3)) & Hex(bb(2)))
Exit Function
Else
UTF16Sarrogate = ""
End If
End Function
Function IsUpperSarrogateCharacter(s As String)
If Hex(AscW(s)) >= Hex(&HD800) And Hex(AscW(s)) <= Hex(&HDBFF) Then
IsUpperSarrogateCharacter = True: Exit Function
Else
IsUpperSarrogateCharacter = False: Exit Function
End If
End Function
Function IsLowerSarrogateCharcter(s As String)
Dim bb() As Byte
If IsUpperSarrogateCharacter(s) = True Then
bb = s
'Debug.Print Hex("&H" & bb(3) & bb(2))
If Hex("&H" & bb(3) & bb(2)) <= Hex(&HDC00) And Hex("&H" & bb(3) & bb(2)) <= Hex(&HDFFF) Then
IsLowerSarrogateCharcter = True: Exit Function
Else
IsLowerSarrogateCharcter = False: Exit Function
End If
End If
End Function
Function VBAAscW(s As String)
If AscW(s) < 0 Then
VBAAscW = AscW(s) + 65536: Exit Function
Else
VBAAscW = AscW(s): Exit Function
End If
End Function
' Shift-Jis
Function VBA_ASC(s As String)
If isSJIS(s) Then
VBA_ASC = Hex(Asc(s)): Exit Function
Else
VBA_ASC = "": Exit Function
End If
End Function
Function isSJIS(ByVal argStr As String) As Boolean
'https://excel-ubara.com/excelvba4/EXCEL_VBA_403.html
    Dim sQuestion As String
    sQuestion = Chr(63) '?:文字リテラルでは誤解があるといけないので
    Dim i As Long
    For i = 1 To Len(argStr)
        If Mid(argStr, i, 1) <> sQuestion And _
           Asc(Mid(argStr, i, 1)) = Asc(sQuestion) Then
            isSJIS = False
            Exit Function
        End If
    Next
    isSJIS = True
End Function

Spill発動

F0 A0 AE B7
𠮷 24 01　60 174 183

UTF-8は、「F0 A0 AE B7」です。4バイト使用しています。
ちなみにデータベース「MySQL」のUTF-8 mb4は、4バイトに対応しているUTF-8のことです。

なんということでしょう。
式は=ToUTF8しか入れていません。
しかし結果は一気に拡がります。
これが配列拡張展開機能Spill(こぼし、流出）です。

これでExcelのシート上でUNICODE UTF-8のコードが確認できます

これとUNICODE関数を使います。[B3]はEvaluateの省略形です。

Sub InsertUniCODE()
Dim ws As Worksheet
Set ws = ActiveSheet
ws.Activate
[B3].FormulaR1C1 = "=UNICODE(R[-1]C[-1])"
[B4].Formula = "=DEc2hex(B3)"
End Sub

さらに次のコードを実行するとWebページの10進と16進の表記も得られます。

Sub InsertWebUnicode()
Dim ws As Worksheet
Set ws = ActiveSheet
    [C3].FormulaR1C1 = "=""&#""&RC[-1]&"";"""
    [C4].FormulaR1C1 = "=""&#x""&RC[-1]&"";"""
End Sub

最後に次を実行してサロゲートペアでもOK
絵文字はないみたいですが、Unicode.orgのリンクも表示します
末尾だけ変えれば取得できるようです

Sub UTF16LESarrogate()
    Dim i As Long, HLink As Hyperlink
    [B6].Formula = "=IF(UTF16Sarrogate(A2)="""",DEC2HEX(B3),UTF16Sarrogate(A2))"
    Range("A3").Value = "UNICODE(DECIMAL)"
    Range("B3").Select
    Selection.NumberFormatLocal = """U+""#"
    Range("A4").Value = "UNICODE(HEX)"
    Columns("B:B").ColumnWidth = 12
    If Range("F4").Hyperlinks.Count > 0 Then
    For Each HLink In Range("F4").Hyperlinks
    HLink.Delete
    Next
    End If
    [F4] = "=HYPERLINK(""http://www.unicode.org/cgi-bin/GetUnihanData.pl?codepoint=""&B4)"
    [D3].Value = "十進Webコード"
    [D4].Value = "16進Webコード"
    [A5].Value = "ASCW(Hex)"
    [A6].Value = "UTF16Sarrogate"
    [B5].Formula = "=DEC2HEX(VBAAscW(A2))"
    [A7].Value = "ASC(HEX)(SJisのみ)"
    [B7].Formula = "=DEC2HEX(VBA_ASC(A2))"
    [A8].Value = "CODE関数(SJisのみ)"
    [B8].Formula = "=IF(isSJIS(A2),DEC2HEX(CODE(A2)),"""")"
    [A1].Value = "UTF-8 16進→"
    Columns("C:C").EntireColumn.AutoFit
    Columns("A:A").EntireColumn.AutoFit
End Sub

UTF-8 16進→ F0 A0 AE B7

𠮷 240 160 174 183
UNICODE(DECIMAL) U+134071 𠮷 十進Webコード

UNICODE(HEX) 20BB7 𠮷 16進Webコード http://www.unicode.org/cgi-bin/GetUnihanData.pl?codepoint=20BB7
Hex(ASCW) D842

UTF16Sarrogate 0xD842 0xDFB7

ASC(HEX)(SJisのみ)

CODE関数（SJisのみ)

Sjis関数はUbara先生から借りています
https://excel-ubara.com/excelvba4/EXCEL_VBA_403.html

このVBAが実際に必要になる事があるのかどうかは、正直分からないところもありますが、
ひょっとして何かのときに役に立つことがあるかもしれないという事で記事にしておきました。

先生、役立ちましたよ！

IsUppersarrogateについて

この上位下位はHighとLowが正しいです。
TipsFoundと発想は同じですが、1文字だけなので、カウンターが2飛びません。
なので下位サロゲートでByte配列にいれて分解し、
3と2を並べます。
このためUTF-16LEしか取れません。

スピルの欠点

これで展開されたセルは一組のセルになります。結合とは違います。
結合はしていないのですが、個別には動かせません。
スタンド使いを倒すには本体を倒す必要があるのと同様、元の式のあるセルを見つけ出し、波動砲を打ち込む必要があります。
ただし、Dec2Hexがセルごとに効いているのがわかるように、値だけは引っ張れます。