Unicodeブロックを元に指定した文字が平仮名なのかカタカナなのか漢字なのかを判別するVBAマクロ

ホーム
Office関連, Excel, Word, PowerPoint
Unicodeブロックを元に指定した文字が平仮名なのかカタカナなのか漢字なのかを判別するVBAマクロ

2014.11.17

Unicodeブロックを元に指定した文字が平仮名なのかカタカナなのか漢字なのかを判別するVBAマクロ

以前書いた「ルビ(ふりがな)を一括設定するWordマクロ」記事で使った、指定した文字が漢字なのかどうかを判別するマクロに、指定した文字が平仮名なのかカタカナなのかを判別するマクロも付け加えてみました。

Option Explicit

Public Sub Sample()
  Dim s As String, tp As String, msg As String
  Dim i As Long
  Const str As String = "ゐどのヰa﨣メ祖レヱえへbゑクヰャ湮ウcヮヴ挽Z"
  
  For i = 1 To Len(str)
    s = Mid(str, i, 1)
    If IsHiragana(s) = True Then
      tp = "ひらがな"
    ElseIf IsKatakana(s) = True Then
      tp = "カタカナ"
    ElseIf IsKanji(s) = True Then
      tp = "漢字"
    Else
      tp = "その他"
    End If
    If i = 1 Then
      msg = "「" & s & "」は【" & tp & "】です。"
    Else
      msg = msg & vbCrLf & "「" & s & "」は【" & tp & "】です。"
    End If
  Next
  MsgBox msg
End Sub

Private Function IsHiragana(ByVal char As String) As Boolean
'ひらがな判別
  Dim cc As Variant
  Dim ret As Boolean
  
  ret = True '初期化
  cc = Val("&H" & Hex(AscW(char)) & "&")
  Select Case cc
    Case 12352 To 12447 'ひらがな(U+3040-U+309F)
    Case Else
      ret = False
  End Select
  IsHiragana = ret
End Function

Private Function IsKatakana(ByVal char As String) As Boolean
'カタカナ判別
  Dim cc As Variant
  Dim ret As Boolean
  
  ret = True '初期化
  cc = Val("&H" & Hex(AscW(char)) & "&")
  Select Case cc
    Case 12448 To 12543 'カタカナ(U+30A0-U+30FF)
    Case Else
      ret = False
  End Select
  IsKatakana = ret
End Function

Private Function IsKanji(ByVal char As String) As Boolean
'漢字判別
  Dim cc As Variant
  Dim ret As Boolean
  
  ret = True '初期化
  cc = Val("&H" & Hex(AscW(char)) & "&")
  Select Case cc
    Case 19968 To 40959   'CJK統合漢字(U+4E00-U+9FFF)
    Case 13312 To 19903   'CJK統合漢字拡張A(U+3400-U+4DBF)
    Case 131072 To 173791 'CJK統合漢字拡張B(U+20000-U+2A6DF)
    Case 173824 To 177983 'CJK統合漢字拡張C(U+2A700-U+2B73F)
    Case 177984 To 178207 'CJK統合漢字拡張D(U+2B740-U+2B81F)
    Case 63744 To 64255   'CJK互換漢字(U+F900-U+FAFF)
    Case 194560 To 195103 'CJK互換漢字補助(U+2F800-U+2FA1F)
    Case Else
      ret = False
  End Select
  IsKanji = ret
End Function