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」を指定すると、言語を自動的に検出してその言語に合った音声が出力されます。
(言語が検出できなかった場合には日本語が設定されます。)
最初のマクロに比べて、これで大分便利になりました。