{"id":4718,"date":"2014-08-08T14:33:57","date_gmt":"2014-08-08T05:33:57","guid":{"rendered":"http:\/\/www.ka-net.org\/blog\/?p=4718"},"modified":"2014-08-08T14:33:57","modified_gmt":"2014-08-08T05:33:57","slug":"%e3%83%a2%e3%83%a4%e3%81%95%e3%81%be%e3%81%ae%e3%82%b7%e3%83%a7%e3%82%a6%e5%90%9b%e3%81%ab%e3%81%84%e3%82%8d%e3%81%84%e3%82%8d%e5%96%8b%e3%82%89%e3%81%9b%e3%82%8bvba%e3%83%9e%e3%82%af%e3%83%ad2","status":"publish","type":"post","link":"https:\/\/www.ka-net.org\/blog\/?p=4718","title":{"rendered":"\u30e2\u30e4\u3055\u307e\u306e\u30b7\u30e7\u30a6\u541b\u306b\u3044\u308d\u3044\u308d\u558b\u3089\u305b\u308bVBA\u30de\u30af\u30ed(2)"},"content":{"rendered":"

\u524d\u56de<\/a>\u306b\u5f15\u304d\u7d9a\u304d\u3001HOYA\u30b5\u30fc\u30d3\u30b9\u682a\u5f0f\u4f1a\u793e\u69d8<\/a>\u304c\u516c\u958b\u3055\u308c\u3066\u3044\u308b\u300cVoiceText Web API<\/a>\u300d\u3092VBA\u30de\u30af\u30ed\u304b\u3089\u4f7f\u3063\u3066\u307f\u308b\u8a71\u3067\u3059\u3002<\/p>\n

\u3053\u306eAPI\u306e\u4f7f\u3044\u65b9\u306f\u524d\u56de\u306e\u8a18\u4e8b<\/a>\u901a\u308a\u3067\u3001\u57fa\u672c\u7684\u306bAPI\u306eURL\u306b\u30d1\u30e9\u30e1\u30fc\u30bf\u30fc\u3092\u4ed8\u3051\u3066\u30ea\u30af\u30a8\u30b9\u30c8\u3092\u9001\u308b\u3060\u3051\u3067\u3059\u3002\u975e\u5e38\u306b\u7c21\u5358\u3067\u3059\u3002<\/p>\n

\u305f\u3060\u3001\u524d\u56de\u8f09\u305b\u305f\u30b3\u30fc\u30c9\u306f\u5358\u306b\u52d5\u4f5c\u78ba\u8a8d\u3059\u308b\u305f\u3081\u306e\u30b3\u30fc\u30c9\u306a\u306e\u3067\u3001\u4eca\u56de\u306f\u4f7f\u3044\u3084\u3059\u3044\u3088\u3046\u306b\u5f15\u6570\u3067\u30d1\u30e9\u30e1\u30fc\u30bf\u30fc\u3092\u6307\u5b9a\u3067\u304d\u308b\u3088\u3046\u306b\u3057\u305f\u3044\u3068\u601d\u3044\u307e\u3059\u3002<\/p>\n

\u30fb\u30fb\u30fb\u3068\u3044\u3046\u308f\u3051\u3067\u3001\u66f8\u3044\u305f\u30b3\u30fc\u30c9\u304c\u4e0b\u8a18\u306b\u306a\u308a\u307e\u3059\u3002<\/p>\n

Option Explicit\r\n\r\nPrivate Declare Function mciSendString Lib "winmm" Alias "mciSendStringA" ( _\r\n        ByVal lpstrCommand As String, _\r\n        ByVal lpstrReturnString As String, _\r\n        ByVal uReturnLength As Long, _\r\n        ByVal hwndCallback As Long) As Long\r\n\r\nPublic Sub Sample()\r\n  PlayVoiceText "\u3042\u3044\u3046\u3048\u304a", "haruka", "happiness", 2, 50, 200, 50\r\n  PlayVoiceText "\u304b\u304d\u304f\u3051\u3053", "show", , , 150, 400, 200\r\n  PlayVoiceText "\u3055\u3057\u3059\u305b\u305d", "hikari", "sadness", 1, 140, 300, 80\r\nEnd Sub\r\n\r\nPublic Sub PlayVoiceText(ByVal txt As String, _\r\n                         ByVal speaker As String, _\r\n                         Optional ByVal emotion As String = "", _\r\n                         Optional ByVal emotion_level As Long = 1, _\r\n                         Optional ByVal pitch As Long = 100, _\r\n                         Optional ByVal speed As Long = 100, _\r\n                         Optional ByVal volume As Long = 100)\r\n'VoiceText Web API\u3092\u4f7f\u3063\u3066\u30c6\u30ad\u30b9\u30c8\u8aad\u307f\u4e0a\u3052\r\n  Dim url As String\r\n  Dim dat As Variant\r\n  Dim body() As Byte\r\n  Dim pathTempFolder As String\r\n  Dim pathWavFile As String\r\n  \r\n  Const adTypeBinary = 1\r\n  Const API_KEY As String = "(API\u30ad\u30fc)" '\u30b3\u30fc\u30c9\u3092\u52d5\u304b\u3059\u969b\u306f\u3053\u3053\u306b\u53d7\u3051\u53d6\u3063\u305fAPI\u30ad\u30fc\u3092\u8a18\u8f09\u3057\u307e\u3059\u3002\r\n  \r\n  '\u30d1\u30e9\u30e1\u30fc\u30bf\u30fc\u30c1\u30a7\u30c3\u30af\r\n  txt = DelBreak(txt)\r\n  If Len(txt) < 1 Then\r\n    MsgBox "\u8aad\u307f\u4e0a\u3052\u308b\u30c6\u30ad\u30b9\u30c8\u3092\u6307\u5b9a\u3057\u3066\u304f\u3060\u3055\u3044\u3002", vbExclamation + vbSystemModal\r\n    Exit Sub\r\n  End If\r\n  If Len(txt) > 200 Then\r\n    MsgBox "\u8aad\u307f\u4e0a\u3052\u308b\u30c6\u30ad\u30b9\u30c8\u306f200\u6587\u5b57\u4ee5\u5185\u306b\u3057\u3066\u304f\u3060\u3055\u3044\u3002", vbExclamation + vbSystemModal\r\n    Exit Sub\r\n  End If\r\n  speaker = LCase(speaker)\r\n  Select Case speaker\r\n    Case "show", "haruka", "hikari", "takeru"\r\n    Case Else\r\n      MsgBox "\u300cspeaker\u300d\u306b\u306f" & vbCrLf & vbCrLf & _\r\n             "show" & vbCrLf & _\r\n             "haruka" & vbCrLf & _\r\n             "hikari" & vbCrLf & _\r\n             "takeru" & vbCrLf & vbCrLf & _\r\n             "\u4ee5\u5916\u3092\u6307\u5b9a\u3057\u306a\u3044\u3067\u304f\u3060\u3055\u3044\u3002", vbExclamation + vbSystemModal\r\n      Exit Sub\r\n  End Select\r\n  '[emotion]\u3092\u6307\u5b9a\u3067\u304d\u308b\u306e\u306f[show]\u4ee5\u5916\r\n  If speaker <> "show" Then\r\n    emotion = LCase(emotion)\r\n    If Len(emotion) > 0 Then\r\n      Select Case emotion\r\n        Case "happiness", "anger", "sadness"\r\n        Case Else\r\n          MsgBox "\u300cemotion\u300d\u306b\u306f" & vbCrLf & vbCrLf & _\r\n                 "happiness" & vbCrLf & _\r\n                 "anger" & vbCrLf & _\r\n                 "sadness" & vbCrLf & vbCrLf & _\r\n                 "\u4ee5\u5916\u3092\u6307\u5b9a\u3057\u306a\u3044\u3067\u304f\u3060\u3055\u3044\u3002", vbExclamation + vbSystemModal\r\n          Exit Sub\r\n      End Select\r\n      Select Case emotion_level\r\n        Case 1, 2\r\n        Case Else\r\n          MsgBox "\u300cemotion_level\u300d\u306b\u306f" & vbCrLf & vbCrLf & _\r\n                   "1" & vbCrLf & _\r\n                   "2" & vbCrLf & vbCrLf & _\r\n                   "\u4ee5\u5916\u3092\u6307\u5b9a\u3057\u306a\u3044\u3067\u304f\u3060\u3055\u3044\u3002", vbExclamation + vbSystemModal\r\n          Exit Sub\r\n      End Select\r\n    End If\r\n  End If\r\n  Select Case pitch\r\n    Case 50 To 200\r\n    Case Else\r\n      MsgBox "\u300cpitch\u300d\u306b\u6307\u5b9a\u3067\u304d\u308b\u6570\u5024\u306e\u7bc4\u56f2\u306f" & vbCrLf & vbCrLf & _\r\n               "50 - 200" & vbCrLf & vbCrLf & _\r\n               "\u3067\u3059\u3002", vbExclamation + vbSystemModal\r\n      Exit Sub\r\n  End Select\r\n  Select Case speed\r\n    Case 50 To 400\r\n    Case Else\r\n      MsgBox "\u300cspeed\u300d\u306b\u6307\u5b9a\u3067\u304d\u308b\u6570\u5024\u306e\u7bc4\u56f2\u306f" & vbCrLf & vbCrLf & _\r\n               "50 - 400" & vbCrLf & vbCrLf & _\r\n               "\u3067\u3059\u3002", vbExclamation + vbSystemModal\r\n      Exit Sub\r\n  End Select\r\n  Select Case volume\r\n    Case 50 To 200\r\n    Case Else\r\n      MsgBox "\u300cvolume\u300d\u306b\u6307\u5b9a\u3067\u304d\u308b\u6570\u5024\u306e\u7bc4\u56f2\u306f" & vbCrLf & vbCrLf & _\r\n               "50 - 200" & vbCrLf & vbCrLf & _\r\n               "\u3067\u3059\u3002", vbExclamation + vbSystemModal\r\n      Exit Sub\r\n  End Select\r\n  \r\n  '\u30d1\u30e9\u30e1\u30fc\u30bf\u30fc\u8a2d\u5b9a\r\n  url = "https:\/\/api.voicetext.jp\/v1\/tts"\r\n  dat = "text=" & EncodeURL(txt) & "&speaker=" & speaker\r\n  If speaker <> "show" Then\r\n    If Len(emotion) > 0 Then\r\n      dat = dat & "&emotion=" & emotion\r\n      dat = dat & "&emotion_level=" & emotion_level\r\n    End If\r\n  End If\r\n  dat = dat & "&pitch=" & pitch\r\n  dat = dat & "&speed=" & speed\r\n  dat = dat & "&volume=" & volume\r\n  'Debug.Print dat '\u78ba\u8a8d\u7528\r\n  \r\n  'wav\u30d5\u30a1\u30a4\u30eb\u30d1\u30b9\u8a2d\u5b9a\r\n  pathTempFolder = GetTempFolderPath\r\n  If Len(Trim(pathTempFolder)) < 1 Then Exit Sub\r\n  pathTempFolder = AddPathSeparator(pathTempFolder)\r\n  pathWavFile = pathTempFolder & "VtwaFile.wav"\r\n  \r\n  'wav\u30d5\u30a1\u30a4\u30eb\u3092\u4e8b\u524d\u306b\u524a\u9664\r\n  If ChkExistsFile(pathWavFile) = True Then DelFile pathWavFile\r\n  \r\n  On Error GoTo Err:\r\n  With CreateObject("WinHttp.WinHttpRequest.5.1")\r\n    .Open "POST", url, False\r\n    .SetRequestHeader "Authorization", "Basic " & EncodeBase64Str(API_KEY & ":")\r\n    .SetRequestHeader "Content-Type", "application\/x-www-form-urlencoded;charset=UTF-8"\r\n    .Send dat\r\n    Select Case .Status\r\n      Case 200\r\n        body = .responseBody\r\n        With CreateObject("ADODB.Stream")\r\n          .Type = adTypeBinary\r\n          .Open\r\n          .Write body\r\n          .SaveToFile pathWavFile\r\n          .Close\r\n        End With\r\n        If ChkExistsFile(pathWavFile) = True Then\r\n          'wav\u30d5\u30a1\u30a4\u30eb\u518d\u751f\r\n          mciSendString "Open " & Chr(34) & pathWavFile & Chr(34), "", 0, 0\r\n          mciSendString "Play " & Chr(34) & pathWavFile & Chr(34) & " wait", "", 0, 0\r\n          mciSendString "Close " & Chr(34) & pathWavFile & Chr(34), "", 0, 0\r\n          DelFile pathWavFile 'wav\u30d5\u30a1\u30a4\u30eb\u524a\u9664\r\n          'Debug.Print "\u51e6\u7406\u304c\u7d42\u4e86\u3057\u307e\u3057\u305f\u3002" '\u78ba\u8a8d\u7528\r\n        End If\r\n      Case Else\r\n        MsgBox "\u51e6\u7406\u304c\u5931\u6557\u3057\u307e\u3057\u305f\u3002" & vbCrLf & vbCrLf & .ResponseText, vbExclamation + vbSystemModal\r\n        Exit Sub\r\n    End Select\r\n  End With\r\n  On Error GoTo 0\r\n  Exit Sub\r\n  \r\nErr:\r\n  MsgBox "\u30a8\u30e9\u30fc\u304c\u767a\u751f\u3057\u307e\u3057\u305f\u3002" & vbCrLf & _\r\n         "\u30a8\u30e9\u30fc\u756a\u53f7\uff1a" & Err.Number & vbCrLf & _\r\n         "\u30a8\u30e9\u30fc\u5185\u5bb9\uff1a" & Err.Description, vbCritical + vbSystemModal\r\nEnd Sub\r\n\r\nPrivate Sub DelFile(ByVal FilePath As String)\r\n'\u30d5\u30a1\u30a4\u30eb\u524a\u9664\r\n  CreateObject("Scripting.FileSystemObject").DeleteFile FilePath, True\r\nEnd Sub\r\n\r\nPrivate Function GetTempFolderPath() As String\r\n'Temp\u30d5\u30a9\u30eb\u30c0\u306e\u30d1\u30b9\u53d6\u5f97\r\n  Dim ret As String\r\n  \r\n  ret = "" '\u521d\u671f\u5316\r\n  On Error Resume Next\r\n  ret = CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2)\r\n  On Error GoTo 0\r\n  GetTempFolderPath = ret\r\nEnd Function\r\n\r\nPrivate Function AddPathSeparator(ByVal str As String) As String\r\n'\u30d1\u30b9\u306e\u533a\u5207\u308a\u6587\u5b57\u8ffd\u52a0\r\n  If Right(str, 1) <> ChrW(92) Then str = str & ChrW(92)\r\n  AddPathSeparator = str\r\nEnd Function\r\n\r\nPrivate Function ChkExistsFile(ByVal FilePath As String) As Boolean\r\n'\u30d5\u30a1\u30a4\u30eb\u306e\u5b58\u5728\u78ba\u8a8d\r\n  Dim ret As Boolean\r\n  \r\n  ret = False '\u521d\u671f\u5316\r\n  With CreateObject("Scripting.FileSystemObject")\r\n    ret = .FileExists(FilePath)\r\n  End With\r\n  ChkExistsFile = ret\r\nEnd Function\r\n\r\nPrivate Function DelBreak(ByVal str As String) As String\r\n'\u6539\u884c\u524a\u9664\r\n  Dim ret As String\r\n  \r\n  ret = "" '\u521d\u671f\u5316\r\n  ret = Replace(str, vbNewLine, "")\r\n  ret = Replace(ret, vbCr, "")\r\n  ret = Replace(ret, vbLf, "")\r\n  DelBreak = ret\r\nEnd Function\r\n\r\nPrivate Function EncodeURL(ByVal str As String) As String\r\n'URL\u30a8\u30f3\u30b3\u30fc\u30c9\r\n  With CreateObject("ScriptControl")\r\n    .Language = "JScript"\r\n    EncodeURL = .CodeObject.encodeURIComponent(str)\r\n  End With\r\nEnd Function\r\n\r\nPrivate Function EncodeBase64Str(ByVal str As String) As String\r\n'\u6587\u5b57\u5217\u3092Base64\u30a8\u30f3\u30b3\u30fc\u30c9\r\n  Dim ret As String\r\n  Dim d() As Byte\r\n  \r\n  Const adTypeBinary = 1\r\n  Const adTypeText = 2\r\n  \r\n  ret = "" '\u521d\u671f\u5316\r\n  On Error Resume Next\r\n  With CreateObject("ADODB.Stream")\r\n    .Open\r\n    .Type = adTypeText\r\n    .Charset = "UTF-8"\r\n    .WriteText str\r\n    .Position = 0\r\n    .Type = adTypeBinary\r\n    .Position = 3\r\n    d = .Read()\r\n    .Close\r\n  End With\r\n  With CreateObject("MSXML2.DOMDocument").createElement("base64")\r\n    .DataType = "bin.base64"\r\n    .nodeTypedValue = d\r\n    ret = .Text\r\n  End With\r\n  On Error GoTo 0\r\n  EncodeBase64Str = ret\r\nEnd Function<\/pre>\n
\u5197\u9577\u306a\u30b3\u30fc\u30c9\u306b\u306a\u3063\u3066\u3057\u307e\u3044\u307e\u3057\u305f\u304c\u3001\u3084\u3063\u3066\u3044\u308b\u3053\u3068\u306f\u5f15\u6570\u3068\u3057\u3066\u53d7\u3051\u53d6\u3063\u305f\u30d1\u30e9\u30e1\u30fc\u30bf\u30fc\u3092\u30ea\u30af\u30a8\u30b9\u30c8\u306b\u304f\u3063\u3064\u3051\u3066\u3001\u53d7\u3051\u53d6\u3063\u305fwav\u30d5\u30a1\u30a4\u30eb\u3092mciSendString<\/span>\u3067\u518d\u751f\u3057\u3066\u3044\u308b\u3060\u3051\u3067\u3059\u3002<\/p>\n
\u4eca\u56de\u306e\u30b3\u30fc\u30c9\u3082\u3001\u305d\u306e\u307e\u307e\u3067\u306f64\u30d3\u30c3\u30c8\u7248\u306eOffice\u3067\u52d5\u4f5c\u3057\u307e\u305b\u3093\u306e\u3067\u300164\u30d3\u30c3\u30c8\u7248Office\u3092\u304a\u4f7f\u3044\u306e\u65b9\u306f\u6ce8\u610f\u3057\u3066\u304f\u3060\u3055\u3044\u3002
\n(\u30b3\u30fc\u30c9\u4e2d\u3001Dir\u3084Kill\u3092\u4f7f\u3063\u3066\u3044\u306a\u3044\u306e\u306f\u3001\u5358\u306bVBScript\u306b\u79fb\u690d\u3057\u3084\u3059\u3044\u3088\u3046\u306b\u3057\u3066\u3044\u308b\u3060\u3051\u3067\u3059\u3002)<\/p>\n
\u4f55\u306f\u3068\u3082\u3042\u308c\u3001\u3053\u308c\u3067VBA\u304b\u3089VoiceText Web API\u304c\u4f7f\u3044\u3084\u3059\u304f\u306a\u308a\u307e\u3057\u305f\u3002
\n\u30b3\u30fc\u30c9\u3092\u8ffd\u52a0\u3059\u308c\u3070\u3001Word\u3067\u30b7\u30e7\u30a6\u541b\u306b\u9078\u629e\u7bc4\u56f2\u3092\u8aad\u307f\u4e0a\u3052\u3066\u3082\u3089\u3063\u305f\u308a\u3001Excel\u306e\u9078\u629e\u30bb\u30eb\u306e\u5185\u5bb9\u3092\u30b7\u30e7\u30a6\u541b\u306b\u8aad\u307f\u4e0a\u3052\u3066\u3082\u3089\u3063\u305f\u308a\u3059\u308b\u3053\u3068\u304c\u3067\u304d\u307e\u3059\u3002<\/p>\n
200\u6587\u5b57\u3068\u3044\u3046\u5236\u9650\u306f\u3042\u308a\u307e\u3059\u304c\u3001\u5341\u5206\u306bVoiceText\u306e\u6027\u80fd\u306e\u7d20\u6674\u3089\u3057\u3055\u3092\u5b9f\u611f<\/span>\u3059\u308b\u3053\u3068\u304c\u3067\u304d\u307e\u3059\u3002<\/p>\n
2014\u5e748\u6708\u6642\u70b9\u3067\u306f\u307e\u3060\u03b2\u7248\u3068\u3044\u3046\u3053\u3068\u3067\u3001\u4eca\u5f8c\u30b5\u30fc\u30d3\u30b9\u306e\u505c\u6b62\u3084\u6709\u6599\u5316\u3059\u308b\u3053\u3068\u3082\u8003\u3048\u3089\u308c\u307e\u3059\u304c\u3001\u4eca\u306f\u307e\u3060\u904a\u3079\u307e\u3059<\/span>\u8a66\u7528\u3067\u304d\u307e\u3059\u306e\u3067\u3001\u8208\u5473\u304c\u3042\u308b\u65b9\u306f\u662f\u975e\u4e00\u5ea6\u304a\u8a66\u3057\u304f\u3060\u3055\u3044\u3002<\/p>\n","protected":false},"excerpt":{"rendered":"\u524d\u56de\u306b\u5f15\u304d\u7d9a\u304d\u3001HOYA\u30b5\u30fc\u30d3\u30b9\u682a\u5f0f\u4f1a\u793e\u69d8\u304c\u516c\u958b\u3055\u308c\u3066\u3044\u308b\u300cVoiceText Web API\u300d\u3092VBA\u30de\u30af\u30ed\u304b\u3089\u4f7f\u3063\u3066\u307f\u308b\u8a71\u3067\u3059\u3002 \u3053\u306eAPI\u306e\u4f7f\u3044\u65b9\u306f\u524d\u56de\u306e\u8a18\u4e8b\u901a\u308a\u3067\u3001\u57fa\u672c\u7684\u306bAPI\u306eURL\u306b\u30d1\u30e9\u30e1\u30fc\u30bf\u30fc\u3092\u4ed8\u3051\u3066\u30ea\u30af […]","protected":false},"author":1,"featured_media":7111,"comment_status":"open","ping_status":"open","sticky":false,"template":"","format":"standard","meta":{"_jetpack_newsletter_access":"","_jetpack_dont_email_post_to_subs":false,"_jetpack_newsletter_tier_id":0,"_jetpack_memberships_contains_paywalled_content":false,"_jetpack_feature_clip_id":0,"_jetpack_memberships_contains_paid_content":false,"footnotes":"","jetpack_publicize_message":"","jetpack_publicize_feature_enabled":true,"jetpack_social_post_already_shared":false,"jetpack_social_options":{"image_generator_settings":{"template":"highway","default_image_id":0,"font":"","enabled":false},"version":2},"jetpack_post_was_ever_published":false},"categories":[4,48,49,58],"tags":[],"class_list":["post-4718","post","type-post","status-publish","format-standard","has-post-thumbnail","hentry","category-office","category-excel-office","category-word-office","category-powerpoint"],"aioseo_notices":[],"aioseo_head":"\n\t\t\n\t\n\t\n\t\n\t\n\t\n\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t\n\t\t