access2010 サロゲートペアを含む文字列をカウント

VBAで .NET Framework のStringInfoクラスを使ってみた。

VSTO/VB.NetでAccessアプリケーションアドインを自分用にいじっているのだけど、VBAでもさっくり使えたらなぁと思ったら使えたのでメモ。サロゲートペアも1カウントする。
正規表現もありか。。。

Option Compare Database
Option Explicit

Private Sub cmd01_Click()
    Dim c As Object, str As String
    'ほっけ/かます/あら/とびうお
    str = ChrW(&HD867) & ChrW(&HDE3D) & _
          ChrW(&HD867) & ChrW(&HDE15) & _
          ChrW(&HD867) & ChrW(&HDE8A) & _
          ChrW(&HD867) & ChrW(&HDE49)
    Me.txt01 = str      
    '2.0 or later
    'http://msdn.microsoft.com/ja-jp/library/c4hkht93%28v=VS.100%29.aspx
    Set c = CreateObject("System.Globalization.StringInfo")
    c.String = Me.txt01
    
    Me.txt02 = c.LengthInTextElements
    Me.txt03 = c.SubstringByTextElements(2)
    Me.txt04 = Len(Me.txt01)
    
    Set c = Nothing
End Sub

ちょっと使う分にはクラスライブラリじゃなくてもいいかな。

Function SurrogatePairCount(strTest As String)
    Dim re As Object, mc As Object
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "[\uD800-\uDBFF][\uDC00-\uDFFF]"
    re.Global = True
    Set mc = re.Execute(strTest)
    SurrogatePairCount = mc.Count
    Set re = Nothing: Set mc = Nothing
End Function

ちょっと気になったのでパフォーマンスを確認。
ほっけ/かます/あら/とびうおを25万匹づつ用意して何匹いるかカウント。

Sub test()
    Dim str As String, max As Long, i As Long, t As Long
    max = 2000000
    str = String$(max, vbNull)
    For i = 1 To max Step 8
        Mid$(str, i, 1) = ChrW(&HD867)
        Mid$(str, i + 1, 1) = ChrW(&HDE3D)
        Mid$(str, i + 2, 1) = ChrW(&HD867)
        Mid$(str, i + 3, 1) = ChrW(&HDE15)
        Mid$(str, i + 4, 1) = ChrW(&HD867)
        Mid$(str, i + 5, 1) = ChrW(&HDE8A)
        Mid$(str, i + 6, 1) = ChrW(&HD867)
        Mid$(str, i + 7, 1) = ChrW(&HDE49)
    Next
    t = timeGetTime
    Debug.Print SurrogatePairCountdnf(str); timeGetTime - t
    t = timeGetTime
    Debug.Print SurrogatePairCountRegExp(str); timeGetTime - t
End Sub

Function SurrogatePairCountdnf(str As String) As Long
    Dim c As Object
    Set c = CreateObject("System.Globalization.StringInfo")
    c.String = str
    SurrogatePairCountdnf = c.LengthInTextElements
    Set c = Nothing
End Function

Function SurrogatePairCountRegExp(strTest As String) As Long
    Dim re As Object, mc As Object
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "[\uD800-\uDBFF][\uDC00-\uDFFF]"
    re.Global = True
    Set mc = re.Execute(strTest)
    SurrogatePairCountRegExp = mc.Count
    Set re = Nothing: Set mc = Nothing
End Function

StringInfoクラスの方が速くて約80ms。正規表現だと550ms。実用のレベルでは変わらない。