Google TTSで文字列を読み上げるマクロ

ホーム
Excel, Office関連, Word, Google関連, 翻訳サービス関連
Google TTSで文字列を読み上げるマクロ

Excel

2012.02.8

Google TTSで文字列を読み上げるマクロ

2012/02/09 追記：

・Google翻訳の言語自動検出機能を追う
・Google TTSで文字列を読み上げるマクロ(言語自動検出対応版)

も合わせてご覧ください。

外国語の翻訳に役立つサービス、Google翻訳には音声を再生する機能が備わっています。
今回はこの機能を利用した、文字列を読み上げるマクロを紹介します。

※ 下記マクロは64ビット版Office環境を考慮していません。

100

101

102

103

104

105

106

107

108

109

110

111

112

113

Option Explicit
 
Private Declare Function mciSendString Lib "winmm" Alias "mciSendStringA" ( _
        ByVal lpstrCommand As String, _
        ByVal lpstrReturnString As String, _
        ByVal uReturnLength As Long, _
        ByVal hwndCallback As Long) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
        ByVal pCaller As Long, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As Long) As Long
 
Public Sub Sample()
  TTSGoogle "こんにちは"
  TTSGoogle "Hello", "en"
End Sub
 
Private Sub TTSGoogle(ByVal txt As String, Optional ByVal lng As String = "ja")
'Google TTSを利用して音声再生
  Dim TTSFilePath As String
  Dim tmp As String
  Dim ret As Long
   
  '**********************************************************
  '■ 対応する言語(引数lng) http://translate.google.com/ より
  '   アイスランド語:is
  '   アフリカーンス語:af
  '   アラビア語:ar
  '   アルバニア語:sq
  '   アルメニア語:hy
  '   イタリア語:it
  '   インドネシア語:id
  '   ウェールズ語:cy
  '   オランダ語:nl
  '   カタロニア語:ca
  '   ギリシャ語:el
  '   クレオール語(ハイチ):ht
  '   クロアチア語:hr
  '   スウェーデン語:sv
  '   スペイン語:es
  '   スロバキア語:sk
  '   スワヒリ語:sw
  '   セルビア語:sr
  '   タイ語:th
  '   タミル語:ta
  '   チェコ語:cs
  '   デンマーク語:da
  '   ドイツ語:de
  '   トルコ語:tr
  '   ノルウェー語:no
  '   ハンガリー語:hu
  '   ヒンディー語:hi
  '   フィンランド語:fi
  '   フランス語:fr
  '   ベトナム語:vi
  '   ポーランド語:pl
  '   ポルトガル語:pt
  '   マケドニア語:mk
  '   ラテン語:la
  '   ラトビア語:lv
  '   ルーマニア語:ro
  '   ロシア語:ru
  '   英語:en
  '   韓国語:ko
  '   中国語:zh-CN
  '   日本語:ja
  '**********************************************************
   
  '文字列確認
  tmp = Replace(txt, "　", "")
  tmp = Replace(tmp, " ", "")
  tmp = Replace(tmp, vbCrLf, "")
  tmp = Replace(tmp, vbCr, "")
  tmp = Replace(tmp, vbLf, "")
  If Len(tmp) < 1 Then
    MsgBox "音声出力する文字列を指定してください。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
    Exit Sub
  End If
  If Len(txt) > 100 Then
    MsgBox "文字数が多すぎます。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
    Exit Sub
  End If
     
  '音声ファイルの保存
  With CreateObject("Scripting.FileSystemObject")
    TTSFilePath = .GetSpecialFolder(2) & Application.PathSeparator & "tts.mp3"
    If .FileExists(TTSFilePath) Then Kill TTSFilePath 'ファイルを事前に削除
    ret = URLDownloadToFile(0&, "http://translate.google.com/translate_tts?tl=" & lng & "&q=" & EncodeURL(txt), TTSFilePath, 0&, 0&)
    If ret <> 0& Then
      MsgBox "音声ファイルがダウンロードできませんでした。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
      Exit Sub
    End If
    If .FileExists(TTSFilePath) = False Then
      MsgBox "音声ファイルが保存されていません。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
      Exit Sub
    End If
  End With
   
  '音声ファイルの再生・削除
  mciSendString "Open " & Chr(34) & TTSFilePath & Chr(34), "", 0&, 0&
  mciSendString "Play " & Chr(34) & TTSFilePath & Chr(34) & " wait", "", 0&, 0&
  mciSendString "Close " & Chr(34) & TTSFilePath & Chr(34), "", 0&, 0&
  Kill TTSFilePath
End Sub
 
Private Function EncodeURL(ByVal sWord As String) As String
  With CreateObject("ScriptControl")
    .Language = "JScript"
    EncodeURL = .CodeObject.encodeURIComponent(sWord)
  End With
End Function