Yahoo!Japanのテキスト解析APIを使ってみた

Yahoo!Japan デベロッパーネットワークトップ > テキスト解析 > キーフレーズ抽出
https://developer.yahoo.co.jp/webapi/jlp/keyphrase/v1/extract.html

Const APIKEY_Y As String = "取得したAPIキー"
Public Function getKeyWords(ByVal str As String) As String
  Dim sUrl As String: sUrl = "https://jlp.yahooapis.jp/KeyphraseService/V1/extract"
  Dim sSendData As String: sSendData = "appid=" & APIKEY_Y & "&sentence=" & str
  Dim objHttp As XMLHTTP: Set objHttp = New XMLHTTP
  Dim objResponse As DOMDocument
  Dim sRet As String: sRet = ""
  Dim el As IXMLDOMNode
  
  objHttp.Open "POST", sUrl, False
  Call objHttp.setRequestHeader("Content-Type", "application/x-www-form-urlencoded")
  objHttp.send (sSendData)
  Set objResponse = objHttp.responseXML
  
  'エラーが返ってきた場合はエラーメッセージを返す
  If objResponse.SelectNodes("/Error").Length > 0 Then
    For Each el In objResponse.SelectNodes("/Error")
      If sRet <> "" Then sRet = sRet & vbCrLf
      sRet = sRet & el.Text
    Next el
    getKeyWords = sRet
    Exit Function
  End If
  
  For Each el In objResponse.SelectNodes("/ResultSet/Result")
    If sRet <> "" Then sRet = sRet & vbCrLf
    sRet = sRet & el.FirstChild.Text & vbTab & el.LastChild.Text
  Next el
  getKeyWords = sRet
  
End Function

校正支援 https://developer.yahoo.co.jp/webapi/jlp/kousei/v1/kousei.html

Public Function getKousei(ByVal str As String)
  Dim sUrl As String: sUrl = "  https://jlp.yahooapis.jp/KouseiService/V1/kousei"
  Dim sSendData As String: sSendData = "appid=" & APIKEY_Y & "&sentence=" & str
  Dim objHttp As XMLHTTP: Set objHttp = New XMLHTTP
  Dim objResponse As DOMDocument
  Dim sRet As String: sRet = ""
  Dim el As IXMLDOMNode
  
  objHttp.Open "POST", sUrl, False
  Call objHttp.setRequestHeader("Content-Type", "application/x-www-form-urlencoded")
  objHttp.send (sSendData)
  Set objResponse = objHttp.responseXML
  
  'エラーが返ってきた場合はエラーメッセージを返す
  If objResponse.SelectNodes("/Error").Length > 0 Then
    For Each el In objResponse.SelectNodes("/Error")
      If sRet <> "" Then sRet = sRet & vbCrLf
      sRet = sRet & el.Text
    Next el
    getKousei sRet
    Exit Function
  End If
  For Each el In objResponse.SelectNodes("/ResultSet/Result")
'    Stop
    If sRet <> "" Then sRet = sRet & vbCrLf
    For i = 0 To el.ChildNodes.Length - 1
      sRet = sRet & el.ChildNodes(i).Text & vbTab
    Next i
    sRet = Left(sRet, Len(sRet) - 1)
  Next el
  getKousei = sRet
End Function

パワポのテキストをExcelに書き出す

Const sFileName as String ="パワポファイルをフルパスで"
Sub Export_PPT()
  Dim pptApp As PowerPoint.Application: Set pptApp = New PowerPoint.Application
  Dim pptFile As PowerPoint.Presentation
  Dim dStartTime As Date: dStartTime = Now()
  
  Set pptFile = pptApp.Presentations.Open(sFileName, msoTrue)
  Dim pptSlide As PowerPoint.Slide
  Dim pptShp As PowerPoint.Shape
  Dim nRow As Long: nRow = 2
  Dim i As Long: Dim j As Long
  
  Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(1)
  ws.Cells.Clear
  
  ws.Range("A1") = "スライド番号"
  ws.Range("B1") = "シェイプ名"
  ws.Range("C1") = "行番号"
  ws.Range("D1") = "列番号"
  ws.Range("E1") = "テキスト"
  ws.Range("E:E").NumberFormatLocal = "@"
  For Each pptSlide In pptFile.Slides
    For Each pptShp In pptSlide.Shapes
      If pptShp.HasTextFrame Then
        If Replace(pptShp.TextFrame.TextRange.Text, Chr(11), vbLf) <> "" Then
        ws.Range("A" & nRow) = pptSlide.SlideNumber
        ws.Range("B" & nRow) = pptShp.Name
        ws.Range("E" & nRow) = Replace(pptShp.TextFrame.TextRange.Text, Chr(11), vbLf)
        nRow = nRow + 1
        End If
      ElseIf pptShp.HasTable Then
        For i = 1 To pptShp.Table.Rows.Count
          For j = 1 To pptShp.Table.Columns.Count
            If pptShp.Table.Cell(i, j).Shape.HasTextFrame Then
              If Replace(pptShp.Table.Cell(i, j).Shape.TextFrame.TextRange.Text, Chr(11), vbLf) <> "" Then
                ws.Range("A" & nRow) = pptSlide.SlideNumber
                ws.Range("B" & nRow) = pptShp.Name
                ws.Range("C" & nRow) = i
                ws.Range("D" & nRow) = j
                ws.Range("E" & nRow) = Replace(pptShp.Table.Cell(i, j).Shape.TextFrame.TextRange.Text, Chr(11), vbLf)
                nRow = nRow + 1
              End If
            End If
          Next j
        Next i
      End If
    
    
    Next pptShp
    DoEvents
  Next pptSlide
  
  pptFile.Close
  pptApp.Quit
  
  MsgBox "書き出したよ(所要時間:" & Format(Now() - dStartTime, "hh:mm:ss") & ")"
  

End Sub

A3RTのText Classification をやってみた

https://a3rt.recruit-tech.co.jp/product/textClassificationAPI/ リファレンスなどはこちら
https://github.com/VBA-tools/VBA-Dictionary JSONの操作で使用
http://blog.goo.ne.jp/xmldtp/e/c7e3c3631d31206f818b30276d0f3091 リクエスト投げるところはここを参考に

うまく結果が返ってきた場合は ラベル{タブ}合致度{改行}のリストを
結果が正しく帰ってこない場合は ステータスコード{タブ}メッセージ
を返します。

09/13 追記
VBA-JSONのURL間違ってた
https://github.com/VBA-tools/VBA-JSON

Const APIKEY As String = "取得したAPIキー"

Public Function getClassifiedResult(ByVal str As String, Optional ByVal model_id As String = "default") As String
    Dim objJSON As Object 'JSONファイルをパースしたもの
    Dim i As Long
    Dim sRet As String: sRet = ""
    target_url = "https://api.a3rt.recruit-tech.co.jp/text_classification/v1/classify"
    sendData = "apikey=" & APIKEY & "&text=" & str & "&model_id=" & model_id

    Set httpobj = CreateObject("MSXML2.XMLHTTP")
    httpobj.Open "POST", target_url, False
    Call httpobj.setRequestHeader("Content-Type", "application/x-www-form-urlencoded")
    httpobj.send (sendData)
    Set objJSON = ParseJson(httpobj.responseText)
    If objJSON("status") <> 0 Then
      getClassifiedResult = objJSON("status") & vbTab & objJSON("message")
      Exit Function
    End If
    
    For i = 1 To objJSON("classes").Count
      If sRet <> "" Then sRet = sRet & vbCrLf
      sRet = sRet & objJSON("classes")(i)("label") & vbTab & FormatPercent(objJSON("classes")(i)("probability"), 2, vbTrue)
    
    Next i
    getClassifiedResult = sRet
End Function

パスワード付のzipファイルを解凍する関数

5/31 追記　自宅環境だとcmdでunzipコマンドが通らない。
どうしたらunzipをcmdで使えるようになるのか調査中。
http://www.info-zip.org/ にあるものを適切にインストールすればよいらしいが引き続き調査中

Public Function unzip(sFileName As String, sPwd As String) As Boolean
  On Error GoTo err_Trap
  
  Dim ShellObj
   
  Set ShellObj = CreateObject("WScript.Shell")
  Debug.Print "unzip -d """ & Replace(sFileName, ".zip", "") & """ -P " & sPwd & """" & sFileName & """"
  ShellObj.Run "unzip -d """ & Replace(sFileName, ".zip", "") & """ -P " & sPwd & " """ & sFileName & """"
  
  unzip = True
  Exit Function
err_Trap:
  Debug.Print Err.Description & Err.Number
  unzip = False
  
 
End Function

アップロード画面への遷移まで

17/05/26追記:Googleへのログインのインターフェースが変わったので現在機能しません。
17/05/31追記:よくわからないClassNameでログインアカウントを選択してよいなら改修できそうな気がする
なお、引っ掛かるのは「(4)ログインアカウントの選択」の工程
クラス名の意味が良くわからないのでこれ使っていいのか悩んでいるところ

定数

Public Const YOURID As String = "【YouTubeアカウント】"
Public Const YOURPWD As String = "【YouTubeパスワード】"

(1)YTトップページに遷移

Public Function YT_Navigate() As InternetExplorer

  Dim ie As InternetExplorer: Set ie = New InternetExplorer
  ie.navigate "https://www.youtube.com/":  Call ieCheck(ie)
  ie.Visible = True
'  Debug.Print "YTトップページに遷移"
  Set YT_Navigate = ie
End Function

(2)YTログアウト

Public Function YT_Logout(ie As InternetExplorer) As Boolean 'ie As InternetExplorer
  Dim dom As HTMLDocument
  Dim el As IHTMLElement
  ie.Visible = True 'debug
  
  Set dom = ie.document
    
  For Each el In dom.getElementsByTagName("a")
'    Debug.Print el.getAttribute("href"), el.innerText
    If Trim(el.innerText) = "ログアウト" Then
      el.click
      Call ieCheck(ie)
      YT_Logout = True
 '     Debug.Print "ログアウトに成功"
      Exit Function
    End If
  Next el
  
  YT_Logout = False 'ログアウト済、という認識になるのかな
'      Debug.Print "ログアウトボタンなし(ログアウト済)"

End Function

(3)YTログインボタンを押下

Public Function YT_Login_Click(ie As InternetExplorer) As Boolean
  Dim dom As HTMLDocument
  Dim el As IHTMLElement
  
  Set dom = ie.document
    
  For Each el In dom.getElementsByTagName("a")
    If Trim(el.innerText) = "ログイン" Then
      el.click
      Call ieCheck(ie)
      YT_Login_Click = True
'      Debug.Print "ログインボタン押下に成功"
      Exit Function
    End If
  Next el
'  Debug.Print "ログインボタン押下に失敗"
  YT_Login_Click = False
  
End Function

(4)ログインアカウントの選択

Public Function YT_SelectLoginAccount(ie As InternetExplorer, sId As String) As Boolean
  
  
  Dim dom As HTMLDocument: Set dom = ie.document
  Dim el As IHTMLElement
  For Each el In dom.getElementsByTagName("button")
  If el.Value = sId Then
    el.click
    Call ieCheck(ie)
'    Debug.Print "アカウント選択に成功"
    YT_SelectLoginAccount = True
    Exit Function
  End If
  Next el
  
  YT_SelectLoginAccount = False
'  Debug.Print "アカウント選択に失敗"
End Function

(5)パスワードを入力し、「ログイン」ボタンを選択

Public Function YT_Login(ie As InternetExplorer, sId As String, sPwd As String) As Boolean
  Dim dom As HTMLDocument
  
  Set dom = ie.document
  Call dom.getElementById("Passwd").setAttribute("value", sPwd)
  dom.getElementById("signIn").click
  Call ieCheck(ie)
  
  YT_Login = True
  Debug.Print "ログイン成功"
End Function

(6)アップロード画面に遷移

Public Function YT_NavigateUpload(ie As InternetExplorer) As Boolean
  
  Dim dom As HTMLDocument
  Dim el As IHTMLElement
  
  Set dom = ie.document
  For Each el In dom.getElementsByTagName("a")
    If el.getAttribute("title") = "アップロード" Then
      el.click
      Call ieCheck(ie)
      YT_NavigateUpload = True
      Exit Function
    End If
  Next el
  
  YT_NavigateUpload = False
  
End Function

これまでのまとめ。

Public Sub YT_Prepare()
  Dim sId As String: sId = YOURID
  Dim sPwd As String: sPwd = YOURPWD
  
  Dim ie As InternetExplorer: Set ie = YT_Navigate()
  Dim i As Long
  Debug.Print "ログアウト:", YT_Logout(ie)
  i = 0
  Do Until YT_Login_Click(ie)
    i = i + 1
    Debug.Print i & "回目ログインボタン押下失敗。0.5秒待ちます。"
    Call MySleep(500)
  Loop
  
  Debug.Print "アカウント選択:", YT_SelectLoginAccount(ie, sId)
  Debug.Print "ログイン:", YT_Login(ie, sPwd)
  Debug.Print "アップロード画面に遷移:", YT_NavigateUpload(ie)
    
    
End Sub

3末でoffなので春スキー検討中。そんなわけで春スキーでも営業しているスキー場の情報をsnow&surfさんからgetしてみた

Public Sub getSnowSurf()
  Dim ie As InternetExplorer: Set ie = New InternetExplorer: ie.navigate "https://snow.gnavi.co.jp/close/": Call ieCheck(ie)
  Dim dom As HTMLDocument: Set dom = ie.document
  Dim el As IHTMLElement
  Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(1):  ws.Cells.Clear
  Dim i As Long: i = 2
  Dim j As Long
  
  For Each el In dom.getElementById("main").getElementsByClassName("area_ski")
'    Stop
  ws.Range("A" & i) = i - 1
  ws.Range("B" & i) = el.getElementsByTagName("h4")(0).innerText
  ws.Range("C" & i) = el.getElementsByTagName("h3")(0).innerText
  If el.getElementsByClassName("condition")(0).getElementsByTagName("td").Length = 8 Then
    For j = 0 To el.getElementsByClassName("condition")(0).getElementsByTagName("td").Length - 1
      ws.Cells(i, j + 4) = el.getElementsByClassName("condition")(0).getElementsByTagName("td")(j).innerText
    Next j
  Else
    ws.Range("L" & i) = el.getElementsByClassName("condition")(0).getElementsByTagName("td")(0).innerText
    For j = 1 To el.getElementsByClassName("condition")(0).getElementsByTagName("td").Length - 1
      ws.Cells(i, j + 3) = el.getElementsByClassName("condition")(0).getElementsByTagName("td")(j).innerText
    Next j
  
  End If
  i = i + 1
  
  Next el
  ie.Quit


End Sub

動画設定情報を取得するプログラム

YouTube APIのlist処理でとろうとしてたが、一部取れない項目があるらしいので力技で。
設定画面に遷移して情報を取得するので、動画の所有者以外はたぶん無理。

Public Sub getSettingVideo(sId As String)
  Dim ie As InternetExplorer
  Dim dom As HTMLDocument
  Dim el As IHTMLElement
  Dim n As Long
  Dim el2 As IHTMLElement
  Set ie = New InternetExplorer
  ie.Visible = True 'debug
  
  ie.navigate "https://www.youtube.com/edit?video_id=" & sId
  Call ieCheck(ie)
  
  Set dom = ie.document
  Debug.Print dom.getElementsByName("title")(0).Value 'タイトル
  For Each el In dom.getElementsByName("description") '説明。ヘッダでも使われてるので…。

    If el.tagName = "TEXTAREA" Then
      Debug.Print el.innerText
      Exit For
    End If
  Next el
  
  'タグ。これは設定されている数をカウントするようにしよう
  n = 0
  For Each el In dom.getElementsByTagName("span")
    If el.getAttribute("role") = "listitem" Then n = n + 1
    
  Next el
  Debug.Print n
  
  
  '公開設定
  For Each el In dom.getElementsByName("privacy")(0).getElementsByTagName("option")
    If el.getAttribute("selected") Then
      Debug.Print el.innerText
      Exit For
    End If
  
  Next el
  

  'コメントを許可 これ、ページ遷移なしでとれたらいいなぁ
  Debug.Print dom.getElementsByName("allow_comments")(0).Value
  
  '動画の評価をユーザに表示する
  Debug.Print dom.getElementsByName("allow_ratings")(0).Value
  '動画のライセンス
  For Each el In dom.getElementsByName("reuse")(0).getElementsByTagName("option")
    If el.getAttribute("selected") Then
      Debug.Print el.innerText
      Exit For
    End If
  Next el

  'シンジケーション
  For Each el In dom.getElementsByName("syndication")
    If el.getAttribute("checked") Then
      Debug.Print el.Value
      Exit For
    End If
  Next el

  '字幕の設定
  For Each el In dom.getElementById("captions_certificate_reason").getElementsByTagName("option")
    If el.getAttribute("selected") Then
      Debug.Print el.innerText
      Exit For
    End If
  Next el
  
  '埋め込みの可不可
  Debug.Print dom.getElementsByName("allow_embedding")(0).getAttribute("checked")
  'チャンネルを登録者に通知
  Debug.Print dom.getElementsByName("creator_share_feeds")(0).getAttribute("checked")
  '年齢制限
  Debug.Print dom.getElementsByName("self_racy")(0).getAttribute("checked")
    
  'カテゴリ
  For Each el In dom.getElementsByTagName("select")
    If el.getAttribute("data-ng-model") = "category" Then Exit For
  Next el
  
  For Each el2 In el.getElementsByTagName("option")
    If el2.getAttribute("selected") = "selected" Then
      Debug.Print el2.innerText
      Exit For
    End If
  Next el2

  '動画の撮影場所
  Debug.Print dom.getElementsByClassName("location-input")(0).Value
  
  '動画の言語はUIが良くわからないので後回し。
  
  '視聴者への翻訳依頼
  Debug.Print dom.getElementsByName("captions_crowdsource")(0).getAttribute("checked")

  '動画の統計情報
  Debug.Print dom.getElementsByName("allow_public_stats")(0).getAttribute("checked")

  '3D動画
  
  For Each el In dom.getElementsByTagName("input")
    If el.getAttribute("data-ng-model") = "threed.is_3d" Then
      Debug.Print el.getAttribute("checked")
      Exit For
    End If
  Next el

  
  'コンテンツに関する申告
  
  For Each el In dom.getElementsByTagName("input")
    If el.getAttribute("data-ng-model") = "product.has_paid_product_placement" Then
      Debug.Print el.getAttribute("checked")
      Exit For
    End If
  Next el
  
  ie.Quit
  


End Sub