Office関連

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

2012/02/09 追記:

関連記事

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

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

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

※ 下記マクロは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"
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

当マクロはGoogle翻訳の機能によって作成されたMP3ファイルをmciSendString関数で再生する仕組みを取っています。
ただ、このサービス自体が公式のものではなく、今後当マクロを利用できなくなる可能性がありますので、その点はご注意ください。

マクロに割り当てたショートカットキーをCSVファイルとして出力するWordマクロ前のページ

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

関連記事

  1. Office関連

    Adobe Reader XIを利用してPDFファイルのページ数を取得するVBAマクロ

    先日Adobe Readerを利用してPDFファイルのページ数を取得す…

  2. Office アドイン

    Office 365でVisio JavaScript APIsを試してみました。

    昨年末にVisio Onlineの機能をJavaScriptで拡張する…

  3. Office関連

    アクティブなIEのタブを閉じるVBAマクロ

    「VBA アクティブ IE タブ 閉じる」といったキーワード検索でのア…

  4. アイコン一覧

    Office 2013 アイコン一覧(B)

    ・Office 2013 アイコン一覧 NUM…

  5. Office アドイン

    [Office用アプリ]Apps for Office サミット!で登壇しました。

    21日(土)に開催されたOffice 用アプリの勉強会「Apps fo…

  6. Office関連

    ドラッグ&ドロップでExcelのアドインを登録するVBScript

    「ドラッグ&ドロップでWordのテンプレートを登録・解除する(VBS)…

コメント

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

Time limit is exhausted. Please reload CAPTCHA.

Translate

Chinese (Simplified)Chinese (Traditional)EnglishFrenchGermanJapaneseKoreanRussianSpanish

最近の記事

アーカイブ

PAGE TOP