VBAで絵文字💖

Unicodeのゴージャスな絵文字を使いたい

毎年6月の年次リリースになっているUnicodeですが、2017年時点の最新版は10.0です。6.0以降はすっかり絵文字が主要テーマになっている印象。目まぐるしく追加されるので、ついて行けません。

今日はVBAで最新の絵文字を使おう！というテーマです。

皆さんよく知っているように、VBAの開発環境は未だにUnicodeベースではないので、エディター内ではUnicodeの文字列リテラルを扱えないし、デバッガーで絵文字を表示することすらできません。
でも、セルやテキストボックスでは絵文字を入力して表示することができます。

Windowsの場合、Segoe UI Emojiという専用のフォントがあり、カラーグリフも持っているのですが、残念ながら現行Excel(2016)ではカラーグリフは表示できません。
同じOffice 2016のアプリケーションでは、Word 2016はカラーグリフに対応しています。

　← Word 2016ではカラー表示

　← Excel 2016では白黒表示

上にはさりげなく表示しましたが、Unicodeの絵文字は複雑な仕様を持っていて、左の顔文字はUCS4でu+1f600というコードの1文字（UTF-16で2ワード、UTF-8では4バイト）で表され、右の家族（ママふたりと男の子2人）はUCS4でu+1f469, u+1f469, u+1f466, u+1f466という4文字をzwjで接続した合字（UTF-16で7ワード、UTF-8では25バイト）という、すごい文字になっています。

こんな絵文字でも、Windows 10やMac OS Xをはじめ、iOS 8以降や、Android 7.0以降ではちゃんと表示されます！😀👩‍👩‍👦‍👦 ← ほら、表示できるでしょう！？

Excelで絵文字を入力するには

さて、こうした文字を入力するために、Excelでは[挿入]タブの[記号と特殊文字]から入力できます。絵文字の場合も、Segoe UI Emojiフォントを選択して、一覧から入力することもできます。

でも、ここから選ぶのはものすごく面倒な上に、一覧には合字による絵文字は出ません。

VBAで絵文字を使う

前置きが長くなったのですが、そこでUnicode表から直接絵文字の文字列を生成するVBAコードを作りました。

emoji.xlsm

' 可変引数で16進文字コードの文字列を渡す
' 例: UCS4String("1f600", "1f469", "200d", "1f469", "200d", "1f466", "200d", "1f466")
Function UCS4String(ParamArray codes() As Variant) As String
    Dim i As Integer
    UCS4String = ""
    For i = LBound(codes) To UBound(codes)
        Dim c As Long
        If TypeName(codes(i)) = "String" Then
            c = "&H" & codes(i)
        Else
            c = CLng(codes(i))
        End If
        If c > 65535 Then
            c = c - &H10000
            UCS4String = UCS4String & ChrW(&HD800 + Int(c / &H400)) & ChrW(&HDC00 + CInt(c And &H3FF))
        Else
            UCS4String = UCS4String & ChrW(c)
        End If
    Next
End Function

Unicodeの絵文字コード表にある数字を直接渡せば使えます。

セルの16進コードを絵文字に変換する

単にセルの中身に絵文字を入れたい場合にも使おう！ということで、選択範囲を変換するコードも書いておきます。

emoji2.xlsm

' 選択されているセルに書かれた文字コードをUnicode文字に変換する
' セルの中身は16進数を空白で区切ったもの
' Unicodeの絵文字コード表(http://unicode.org/emoji/charts/full-emoji-list.html)
' からコピペしてもOK
' 例: U+1F468 U+1F3FB U+200D U+2708 U+FE0F
Sub ConvertUCS4()
    For i = 1 To Selection.Areas.Count
        Dim r As Range
        Set r = Selection.Areas(i)
        For j = 1 To r.Rows.Count
            For k = 1 To r.Columns.Count
                Dim els() As String, str As String
                With r.Cells(j, k)
                    els = Split(.Value, " ")
                    str = ""
                    For l = LBound(els) To UBound(els)
                        If Len(els(l)) > 1 Then ' 実質中身がない空白部はスキップ
                            ' u+xxxx形式の場合はu+部分を削除
                            If LCase(Left(els(l), 2)) = "u+" Then els(l) = Mid(els(l), 3)
                            str = str & UCS4String(els(l))
                        End If
                    Next
                    .Value = str
                End With
            Next
        Next
    Next
End Sub