Office関連

Google TTSで文字列を読み上げるマクロ(言語自動検出対応版)

2012/2/15 追記:
下記マクロをExcel 2007/2010に対応したアドインファイルにしました。
ファイルは「Google TTSで文字列を読み上げるExcelアドイン」からダウンロードすることができます。

前々回の記事でGoogle翻訳の音声再生機能を利用した文字列の読み上げマクロを紹介し、前回の記事で言語を自動検出する仕組みについて触れました。
今回は「Google TTSで文字列を読み上げるマクロ」を改良して言語の自動検出に対応させてみたいと思います。

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

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"
  TTSGoogle Selection.Text, "auto"
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/ より
  '   自動検出:auto
  '   アイスランド語: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
  
  '言語自動検出対応
  Select Case LCase$(lng)
    Case "auto"
      lng = DetectLanguageG(txt)
      'Debug.Print lng
      If Len(lng) < 1 Then
        MsgBox "自動検出できませんでした。" & vbCrLf & "言語を「日本語」に設定します。", vbInformation + vbSystemModal
        lng = "ja"
      End If
  End Select
  
  '音声ファイルの保存
  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 DetectLanguageG(ByVal txt As String) As String
'言語自動検出
  Dim ret As String
  Dim js As String
  
  ret = "": js = "" '初期化
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", "http://translate.google.com/translate_a/t?client=0&sl=auto&text=" & EncodeURL(txt), False
    .Send
    If .Status = 200 Then js = .responseText
  End With
  On Error GoTo 0
  If Len(js) > 0 Then
    js = "(" & js & ")"
    With CreateObject("ScriptControl")
      .Language = "JScript"
      ret = .CodeObject.eval(js).src
    End With
  End If
  DetectLanguageG = ret
End Function

Private Function EncodeURL(ByVal sWord As String) As String
  With CreateObject("ScriptControl")
    .Language = "JScript"
    EncodeURL = .CodeObject.encodeURIComponent(sWord)
  End With
End Function

上記マクロでは引数lngに「auto」を指定すると、言語を自動的に検出してその言語に合った音声が出力されます。
(言語が検出できなかった場合には日本語が設定されます。)
最初のマクロに比べて、これで大分便利になりました。

Google翻訳の言語自動検出機能を追う前のページ

Google TTSで文字列を読み上げるExcelアドイン次のページ

関連記事

  1. Office関連

    Gmail APIを使ってメール送信するVBAマクロ(3)

    前回、前々回とGmail APIを扱ってきましたが、今回は前々回の記事…

  2. Office関連

    右クリックから図形の配置 for Office 2013

    HPの掲示板に"右クリックから「配置」を実行できないか?"という質問が…

  3. Office関連

    インストールされたフォントの一覧を取得するVBAマクロ

    最近自分の周りでPowerPoint VBAが流行っているようだったの…

  4. Office関連

    Google TTSで文字列を読み上げるExcelアドイン

    前回の記事で書いたGoogle TTSで文字列を読み上げるマクロ(言語…

  5. Office関連

    Excel 2016 Previewで追加された新しい関数

    ※ 下記情報はOffice 2016 Preview版を元にしています…

コメント

  1. この記事へのコメントはありません。

Time limit is exhausted. Please reload CAPTCHA.

Translate

Chinese (Simplified)Chinese (Traditional)EnglishFrenchGermanJapaneseKoreanRussianSpanish

最近の記事

アーカイブ

PAGE TOP