利用VBA来实现，输入日文之后，输出它的假名即读法

背景：当你输日文汉字的额时候，输出它的读音。

如下图所示

 

实现的代码如下

Option Explicit

' Replace を まとめて おこなう
Private Function ReplaceA(ByVal s As String, ByVal t1 As String, ByVal t2 As String) As String

    Dim u1() As String: u1 = Split(t1)
    Dim u2() As String: u2 = Split(t2)
    Dim i As Integer
    
    For i = 0 To UBound(u1)
        s = Replace(s, u1(i), u2(i))
    Next
    
    ReplaceA = s

End Function

' カタカナを ローマ字（英語式）に おきかえる
Public Function KatakanaToRoomaziE(ByVal s As String) As String

    ' 前処理
    s = ReplaceA(s, "ッン", "'ン")

    ' 拗音・特殊音
    s = ReplaceA(s, "キャ キュ キョ", "kya kyu kyo")
    s = ReplaceA(s, "シャ シュ ショ", "sha shu sho")
    s = ReplaceA(s, "チャ チュ チョ", "cha chu cho")
    s = ReplaceA(s, "ニャ ニュ ニョ", "nya nyu nyo")
    s = ReplaceA(s, "ヒャ ヒュ ヒョ", "hya hyu hyo")
    s = ReplaceA(s, "ミャ ミュ ミョ", "mya myu myo")
    s = ReplaceA(s, "リャ リュ リョ", "rya ryu ryo")
    s = ReplaceA(s, "ギャ ギュ ギョ", "gya gyu gyo")
    s = ReplaceA(s, "ジャ ジュ ジョ", "ja ju jo")
    s = ReplaceA(s, "ヂャ ヂュ ヂョ", "ja ju jo")
    s = ReplaceA(s, "ビャ ビュ ビョ", "bya byu byo")
    s = ReplaceA(s, "ピャ ピュ ピョ", "pya pyu pyo")
    
    ' 直音
    s = ReplaceA(s, "ア イ ウ エ オ", "a i u e o")
    s = ReplaceA(s, "カ キ ク ケ コ", "ka ki ku ke ko")
    s = ReplaceA(s, "サ シ ス セ ソ", "sa shi su se so")
    s = ReplaceA(s, "タ チ ツ テ ト", "ta chi tsu te to")
    s = ReplaceA(s, "ナ ニ ヌ ネ ノ", "na ni nu ne no")
    s = ReplaceA(s, "ハ ヒ フ ヘ ホ", "ha hi fu he ho")
    s = ReplaceA(s, "マ ミ ム メ モ", "ma mi mu me mo")
    s = ReplaceA(s, "ヤ ユ ヨ", "ya yu yo")
    s = ReplaceA(s, "ラ リ ル レ ロ", "ra ri ru re ro")
    s = ReplaceA(s, "ワ ヰ ヱ ヲ", "wa i e o")
    s = ReplaceA(s, "ガ ギ グ ゲ ゴ", "ga gi gu ge go")
    s = ReplaceA(s, "ザ ジ ズ ゼ ゾ", "za ji zu ze zo")
    s = ReplaceA(s, "ダ ヂ ヅ デ ド", "da ji zu de do")
    s = ReplaceA(s, "バ ビ ブ ベ ボ", "ba bi bu be bo")
    s = ReplaceA(s, "パ ピ プ ペ ポ", "pa pi pu pe po")
    
    ' 撥音
    s = Replace(s, "ン", "n")
    s = ReplaceA(s, "nb nm np", "mb mm mp")
    
    ' 促音
    s = ReplaceA(s, "ッk ッs ッt ッn ッh ッm ッy ッr ッw", "kk ss tt nn hh mm yy rr ww")
    s = ReplaceA(s, "ッg ッz ッd ッb ッp", "gg zz dd bb pp")
    s = ReplaceA(s, "ッc ッf ッj", "tc ff jj")
    s = Replace(s, "ッ", "'")
    
    ' 長音
    s = Replace(s, "iー", "ii")
    s = Replace(s, "ー", "")
    
    KatakanaToRoomaziE = StrConv(StrConv(s, vbNarrow), vbLowerCase)

End Function

' EOF
Function GetPhonetic(セル As Range, _
                        Optional ByVal 変換 As Integer = 8, _
                        Optional ByVal 全て As Boolean = False)
    Dim strPhonetic As String
    GetPhonetic = StrConv(Application.GetPhonetic(セル), 変換)
    strPhonetic = GetPhonetic
    If 全て = True Then
        Do Until strPhonetic = ""
            strPhonetic = StrConv(Application.GetPhonetic(), 変換)
            If strPhonetic <> "" Then
                GetPhonetic = GetPhonetic & " ; " & strPhonetic
            End If
        Loop
    End If
End Function

Function DelAIUEO(ByVal romaStr As String) As String
    Dim delStr As String
    delStr = romaStr
    delStr = Replace(delStr, "A", "")
    delStr = Replace(delStr, "I", "")
    delStr = Replace(delStr, "U", "")
    delStr = Replace(delStr, "E", "")
    delStr = Replace(delStr, "O", "")
    
    delStr = Replace(delStr, "a", "")
    delStr = Replace(delStr, "i", "")
    delStr = Replace(delStr, "u", "")
    delStr = Replace(delStr, "e", "")
    delStr = Replace(delStr, "o", "")
    
    DelAIUEO = delStr
End Function

　　

转载于:https://www.cnblogs.com/killclock048/p/11097954.html