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. Google関連

    [Google Apps Script]スプレッドシートのセル範囲に指定した値が含まれているかを判定…

    先日、もり(@moripro3)さんから、「スプレッドシートの二次元配…

  2. Office関連

    漢字かな交じり文をひらがなにするマクロ

    Yahoo!のテキスト解析Web API(ルビ振り)を使用して、漢字か…

  3. Office関連

    Office 365 APIをVBAから呼び出す(2)

    前回の記事ではOffice 365とAzure ADの紐づけを行いまし…

  4. Excel

    PDFファイルにヘッダーとフッターを追加するVBAマクロ

    mougに“マクロで既存のPDFファイルのフッターを操作(追加)したい…

  5. Office関連

    指定したスライドにユーザー設定レイアウトを適用するPowerPointマクロ

    PowerPointにはオリジナルのレイアウト(ユーザー設定レイアウト…

コメント

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

Time limit is exhausted. Please reload CAPTCHA.

Translate

最近の記事

アーカイブ

PAGE TOP