Phonetic関数を利用して文章中の漢字だけのフリガナを取得したい。

VBAを使用してエクセルのセルに記入した文章をパワーポイントのSlideにあるShapeに転送するプログラムを作成しています。その時、Phonetic関数を利用してフリガナも同時に転送できるようになったのですが、そのフリガナが文章全体のフリガナになってしまっています。つまり、文章中のひらがなにもフリガナがついています。できれば、フリガナは文章中の漢字だけのフリガナに限定をしたいのですが、どうすればよいでしょうか。教えて頂けないでしょうか。

No.3 ベストアンサー 回答者： ggrksdqn 回答日時： 2020/11/21 16:06

No.1 です。

やり直しました。
漢字は熟語で区切ってふりがなを取得し、漢字以外は文字数に応じて半角スペースで埋めています（半角文字は半角スペース1個、全角文字は半角スペース2個に置き換えます）

Sub test()
Dim testText As String

testText = _
"菅義偉首相は21日午後、新型コロナウイルス感染症対策本部を官邸で開催する。" & _
"感染が急速に拡大している地域に関し、観光支援事業「Go　To　トラベル」の適用制限を巡り見解を表明する。"
Debug.Print GetFurigana(testText)

End Sub
'文字列を受け取って、ふりがなを返す
Public Function GetFurigana(srcText As String) As String

'引数の文字列が空の場合は処理を抜ける
If srcText = "" Then Exit Function

Dim furigana As String 'ふりがな
Dim i As Long

'文字数だけ繰り返す
For i = 1 To Len(srcText)

Dim c As String: c = Mid(srcText, i, 1) '一文字取り出す
Dim nonKanji As String '漢字以外
Dim cWord As String 'compound word 熟語
Dim temp As String

'漢字の場合、前の漢字と結合する
If c Like "[亜-黑]" Then
cWord = cWord & c

'漢字以外
Else
nonKanji = nonKanji & c
'空文字を回避（空文字をGetPhoneticすると変になるので）
If cWord <> "" Then

'漢字以外の文字の数だけスペースを追加
'半角文字は半角スペース1個、全角文字は半角スペース2個
furigana = furigana & _
Space(LenB(StrConv(nonKanji, vbFromUnicode)))

'カタカナをｹﾞｯﾄ
temp = Application.GetPhonetic(cWord)
'ひらがなに変換
temp = StrConv(temp, vbHiragana)
'ふりがなと結合する
furigana = furigana & temp

temp = ""
cWord = ""
nonKanji = ""
End If
End If

Next

GetFurigana = furigana
End Function

この回答へのお礼

このようなやり方で解決ができるのですね。勉強になりました。有難うございました。

お礼日時：2020/11/22 23:04

No.2 回答者： ggrksdqn 回答日時： 2020/11/21 15:18

No.1です。

さっきのコードは忘れてください。これだと1字ずつふりがなを振ってるので、熟語の読み方がおかしくなってます。

No.1 回答者： ggrksdqn 回答日時： 2020/11/21 15:13

ふりがなだけ別に取得するなら下のコードで事足りそうです。

漢字の上にルビを振るのなら別の工夫が要りそうです。

Sub test()
Dim testText As String

testText = _
"「文化庁コンテンツ転載文7関係1」とは、「GNU本ライセンス投稿記事107引用7」制度をしない。" & _
"「CC」とも、「URLSAテンプレートウェブページ」に有するない。「権利情報」とは、" & _
"Creative作風提供要件3充足107と可否の濫記事、またここを文章権とする記事を得ます。"
Debug.Print GetFurigana(testText)

End Sub

'文字列を受け取って、ふりがなを返す
Public Function GetFurigana(srcText As String) As String

'引数の文字列が空の場合は処理を抜ける
If srcText = "" Then Exit Function

Dim furigana As String
Dim c As String

Dim i As Long
'文字数だけ繰り返す
For i = 1 To Len(srcText)
c = Mid(srcText, i, 1) '一文字取り出す
If c Like "[亜-熙]" Then
c = Application.GetPhonetic(c) 'ふりがなをｹﾞｯﾄ
c = StrConv(c, vbHiragana) ' ひらがな

furigana = furigana & c

　　’漢字以外の場合はどうするか。（空白で埋めるとか）
Else
'なんらかの処理
End If
Next

GetFurigana = furigana
End Function