Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
Rem --------------------------------------------------
Rem 文字列変換関数 からの抜粋
Rem --------------------------------------------------
Option Explicit
Rem 文字列を一文字毎の配列に変換
Rem @param base_str 入力文字列
Rem @return As String(1 To #) 文字配列
Function ToCharArray(base_str) As String()
Dim arr() As String
ReDim arr(1 To Len(base_str))
Dim i As Long
For i = 1 To Len(base_str)
arr(i) = Mid(base_str, i, 1)
ToCharArray = arr
End Function
Public Function GetCharVbStrConv(c As String) As VbStrConv
If IsHiragana(c) Then GetCharVbStrConv = VbStrConv.vbHiragana
If IsFullKatakana(c) Then GetCharVbStrConv = VbStrConv.vbKatakana + VbStrConv.vbWide
If IsHalfKatakana(c) Then GetCharVbStrConv = VbStrConv.vbKatakana + VbStrConv.vbNarrow
End Function
'全角ひらがな ※ヴはカタカナとする
Public Function IsHiragana(c As String) As Boolean
IsHiragana = (c Like "[ぁ-ん]" Or c Like "[" & ChrW(12436) & "ゝゞ]") '12436:うの濁音
End Function
'全角カタカナ ※ヴはカタカナとする
Public Function IsFullKatakana(c As String) As Boolean
IsFullKatakana = (c Like "[ァ-ヶ]" Or c Like "[ヽヾ]")
End Function
Public Function IsHalfKatakana(c As String, Optional IncludeMark As Boolean = False) As Boolean
IsHalfKatakana = (c Like "[ヲ-ン]")
If IncludeMark Then IsHalfKatakana = IsHalfKatakana Or (c Like "[ー゙゚]")
End Function
Public Function IsKatakana(c As String) As Boolean
IsKatakana = IsFullKatakana(c) Or IsHalfKatakana(c)
End Function
Rem 濁点を取り除いて清音にする
Rem @param base_str 入力文字列
Rem @param IsWithoutHalf 半濁音を消すか(既定:True)
Rem @return As String 出力文字列
Rem @example
Rem Missing >> String ""
Rem String "" >> String ""
Rem String "か゛き゛く゛け゛こ゛" >> String "かきくけこ"
Rem String "カ゛キ゛ク゛ケ゛コ゛" >> String "カキクケコ"
Rem String "ガギグゲゴ" >> String "カキクケコ"
Rem String "ガギグゲゴ" >> String "カキクケコ"
Rem String "あ゛い゛う゛え゛ん゛" >> String "あいうえん"
Rem String "は゜ひ゜ぷぺぽ" >> String "はひふへほ"
Rem String "漢字123123ABC" >> String "漢字123123ABC"
Rem String "ヴゝゞヽヾー゙゚" >> String "うゝゝヽヽー"
Rem String "は゛は゜" >> String "はは"
Public Function RemoveDakuten(ByVal base_str, Optional IsWithoutHalf As Boolean = True) As String
RemoveDakuten = ""
If IsMissing(base_str) Then Exit Function
base_str = Replace(base_str, "゛", "")
base_str = Replace(base_str, Chr(222), "")
base_str = Replace(base_str, ChrW(12441), "")
If IsWithoutHalf Then
base_str = Replace(base_str, "゜", "")
base_str = Replace(base_str, Chr(223), "")
base_str = Replace(base_str, ChrW(12442), "")
End If
If Len(base_str) = 0 Then Exit Function
Dim kataDaku As String
kataDaku = StrConv(base_str, vbKatakana)
Dim kataSei As String
kataSei = StrConv(kataDaku, vbNarrow)
kataSei = Replace(kataSei, Chr(222), "")
If (IsWithoutHalf = True) Then
kataSei = Replace(kataSei, Chr(223), "")
End If
kataSei = StrConv(kataSei, vbWide)
Dim ret_str As String: ret_str = base_str
Dim idx As Long, strType As VbStrConv
For idx = 1 To Len(ret_str)
strType = GetCharVbStrConv(Mid(ret_str, idx, 1))
Mid(ret_str, idx, 1) = Mid( _
IIf(VbStrConv.vbKatakana <= strType And strType <= VbStrConv.vbHiragana, _
StrConv(kataSei, strType), base_str), idx, 1)
RemoveDakuten = ret_str
End Function
Function 濁点付与(v)
v = RemoveDakuten(v) '濁点を削除
v = Join(ToCharArray(v), "゛") & "゛" '全ての文字に濁点を付与
濁点付与 = v
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.