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がセルごとに効いているのがわかるように、値だけは引っ張れます。