モヤさまのショウ君にいろいろ喋らせるVBAマクロ(2)

ホーム
Office関連, Excel, Word, PowerPoint
モヤさまのショウ君にいろいろ喋らせるVBAマクロ(2)

Office関連

2014.08.8

モヤさまのショウ君にいろいろ喋らせるVBAマクロ(2)

前回に引き続き、HOYAサービス株式会社様が公開されている「VoiceText Web API」をVBAマクロから使ってみる話です。

このAPIの使い方は前回の記事通りで、基本的にAPIのURLにパラメーターを付けてリクエストを送るだけです。非常に簡単です。

ただ、前回載せたコードは単に動作確認するためのコードなので、今回は使いやすいように引数でパラメーターを指定できるようにしたいと思います。

・・・というわけで、書いたコードが下記になります。

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

Public Sub Sample()
  PlayVoiceText "あいうえお", "haruka", "happiness", 2, 50, 200, 50
  PlayVoiceText "かきくけこ", "show", , , 150, 400, 200
  PlayVoiceText "さしすせそ", "hikari", "sadness", 1, 140, 300, 80
End Sub

Public Sub PlayVoiceText(ByVal txt As String, _
                         ByVal speaker As String, _
                         Optional ByVal emotion As String = "", _
                         Optional ByVal emotion_level As Long = 1, _
                         Optional ByVal pitch As Long = 100, _
                         Optional ByVal speed As Long = 100, _
                         Optional ByVal volume As Long = 100)
'VoiceText Web APIを使ってテキスト読み上げ
  Dim url As String
  Dim dat As Variant
  Dim body() As Byte
  Dim pathTempFolder As String
  Dim pathWavFile As String
  
  Const adTypeBinary = 1
  Const API_KEY As String = "(APIキー)" 'コードを動かす際はここに受け取ったAPIキーを記載します。
  
  'パラメーターチェック
  txt = DelBreak(txt)
  If Len(txt) < 1 Then
    MsgBox "読み上げるテキストを指定してください。", vbExclamation + vbSystemModal
    Exit Sub
  End If
  If Len(txt) > 200 Then
    MsgBox "読み上げるテキストは200文字以内にしてください。", vbExclamation + vbSystemModal
    Exit Sub
  End If
  speaker = LCase(speaker)
  Select Case speaker
    Case "show", "haruka", "hikari", "takeru"
    Case Else
      MsgBox "「speaker」には" & vbCrLf & vbCrLf & _
             "show" & vbCrLf & _
             "haruka" & vbCrLf & _
             "hikari" & vbCrLf & _
             "takeru" & vbCrLf & vbCrLf & _
             "以外を指定しないでください。", vbExclamation + vbSystemModal
      Exit Sub
  End Select
  '[emotion]を指定できるのは[show]以外
  If speaker <> "show" Then
    emotion = LCase(emotion)
    If Len(emotion) > 0 Then
      Select Case emotion
        Case "happiness", "anger", "sadness"
        Case Else
          MsgBox "「emotion」には" & vbCrLf & vbCrLf & _
                 "happiness" & vbCrLf & _
                 "anger" & vbCrLf & _
                 "sadness" & vbCrLf & vbCrLf & _
                 "以外を指定しないでください。", vbExclamation + vbSystemModal
          Exit Sub
      End Select
      Select Case emotion_level
        Case 1, 2
        Case Else
          MsgBox "「emotion_level」には" & vbCrLf & vbCrLf & _
                   "1" & vbCrLf & _
                   "2" & vbCrLf & vbCrLf & _
                   "以外を指定しないでください。", vbExclamation + vbSystemModal
          Exit Sub
      End Select
    End If
  End If
  Select Case pitch
    Case 50 To 200
    Case Else
      MsgBox "「pitch」に指定できる数値の範囲は" & vbCrLf & vbCrLf & _
               "50 - 200" & vbCrLf & vbCrLf & _
               "です。", vbExclamation + vbSystemModal
      Exit Sub
  End Select
  Select Case speed
    Case 50 To 400
    Case Else
      MsgBox "「speed」に指定できる数値の範囲は" & vbCrLf & vbCrLf & _
               "50 - 400" & vbCrLf & vbCrLf & _
               "です。", vbExclamation + vbSystemModal
      Exit Sub
  End Select
  Select Case volume
    Case 50 To 200
    Case Else
      MsgBox "「volume」に指定できる数値の範囲は" & vbCrLf & vbCrLf & _
               "50 - 200" & vbCrLf & vbCrLf & _
               "です。", vbExclamation + vbSystemModal
      Exit Sub
  End Select
  
  'パラメーター設定
  url = "https://api.voicetext.jp/v1/tts"
  dat = "text=" & EncodeURL(txt) & "&speaker=" & speaker
  If speaker <> "show" Then
    If Len(emotion) > 0 Then
      dat = dat & "&emotion=" & emotion
      dat = dat & "&emotion_level=" & emotion_level
    End If
  End If
  dat = dat & "&pitch=" & pitch
  dat = dat & "&speed=" & speed
  dat = dat & "&volume=" & volume
  'Debug.Print dat '確認用
  
  'wavファイルパス設定
  pathTempFolder = GetTempFolderPath
  If Len(Trim(pathTempFolder)) < 1 Then Exit Sub
  pathTempFolder = AddPathSeparator(pathTempFolder)
  pathWavFile = pathTempFolder & "VtwaFile.wav"
  
  'wavファイルを事前に削除
  If ChkExistsFile(pathWavFile) = True Then DelFile pathWavFile
  
  On Error GoTo Err:
  With CreateObject("WinHttp.WinHttpRequest.5.1")
    .Open "POST", url, False
    .SetRequestHeader "Authorization", "Basic " & EncodeBase64Str(API_KEY & ":")
    .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
    .Send dat
    Select Case .Status
      Case 200
        body = .responseBody
        With CreateObject("ADODB.Stream")
          .Type = adTypeBinary
          .Open
          .Write body
          .SaveToFile pathWavFile
          .Close
        End With
        If ChkExistsFile(pathWavFile) = True Then
          'wavファイル再生
          mciSendString "Open " & Chr(34) & pathWavFile & Chr(34), "", 0, 0
          mciSendString "Play " & Chr(34) & pathWavFile & Chr(34) & " wait", "", 0, 0
          mciSendString "Close " & Chr(34) & pathWavFile & Chr(34), "", 0, 0
          DelFile pathWavFile 'wavファイル削除
          'Debug.Print "処理が終了しました。" '確認用
        End If
      Case Else
        MsgBox "処理が失敗しました。" & vbCrLf & vbCrLf & .ResponseText, vbExclamation + vbSystemModal
        Exit Sub
    End Select
  End With
  On Error GoTo 0
  Exit Sub
  
Err:
  MsgBox "エラーが発生しました。" & vbCrLf & _
         "エラー番号：" & Err.Number & vbCrLf & _
         "エラー内容：" & Err.Description, vbCritical + vbSystemModal
End Sub

Private Sub DelFile(ByVal FilePath As String)
'ファイル削除
  CreateObject("Scripting.FileSystemObject").DeleteFile FilePath, True
End Sub

Private Function GetTempFolderPath() As String
'Tempフォルダのパス取得
  Dim ret As String
  
  ret = "" '初期化
  On Error Resume Next
  ret = CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2)
  On Error GoTo 0
  GetTempFolderPath = ret
End Function

Private Function AddPathSeparator(ByVal str As String) As String
'パスの区切り文字追加
  If Right(str, 1) <> ChrW(92) Then str = str & ChrW(92)
  AddPathSeparator = str
End Function

Private Function ChkExistsFile(ByVal FilePath As String) As Boolean
'ファイルの存在確認
  Dim ret As Boolean
  
  ret = False '初期化
  With CreateObject("Scripting.FileSystemObject")
    ret = .FileExists(FilePath)
  End With
  ChkExistsFile = ret
End Function

Private Function DelBreak(ByVal str As String) As String
'改行削除
  Dim ret As String
  
  ret = "" '初期化
  ret = Replace(str, vbNewLine, "")
  ret = Replace(ret, vbCr, "")
  ret = Replace(ret, vbLf, "")
  DelBreak = ret
End Function

Private Function EncodeURL(ByVal str As String) As String
'URLエンコード
  With CreateObject("ScriptControl")
    .Language = "JScript"
    EncodeURL = .CodeObject.encodeURIComponent(str)
  End With
End Function

Private Function EncodeBase64Str(ByVal str As String) As String
'文字列をBase64エンコード
  Dim ret As String
  Dim d() As Byte
  
  Const adTypeBinary = 1
  Const adTypeText = 2
  
  ret = "" '初期化
  On Error Resume Next
  With CreateObject("ADODB.Stream")
    .Open
    .Type = adTypeText
    .Charset = "UTF-8"
    .WriteText str
    .Position = 0
    .Type = adTypeBinary
    .Position = 3
    d = .Read()
    .Close
  End With
  With CreateObject("MSXML2.DOMDocument").createElement("base64")
    .DataType = "bin.base64"
    .nodeTypedValue = d
    ret = .Text
  End With
  On Error GoTo 0
  EncodeBase64Str = ret
End Function

冗長なコードになってしまいましたが、やっていることは引数として受け取ったパラメーターをリクエストにくっつけて、受け取ったwavファイルをmciSendStringで再生しているだけです。

今回のコードも、そのままでは64ビット版のOfficeで動作しませんので、64ビット版Officeをお使いの方は注意してください。
(コード中、DirやKillを使っていないのは、単にVBScriptに移植しやすいようにしているだけです。)

何はともあれ、これでVBAからVoiceText Web APIが使いやすくなりました。
コードを追加すれば、Wordでショウ君に選択範囲を読み上げてもらったり、Excelの選択セルの内容をショウ君に読み上げてもらったりすることができます。

200文字という制限はありますが、十分にVoiceTextの性能の素晴らしさを実感することができます。

2014年8月時点ではまだβ版ということで、今後サービスの停止や有料化することも考えられますが、今はまだ遊べます試用できますので、興味がある方は是非一度お試しください。