カスタム検索
Office関連

goo.glで短縮URLを取得する(Office VBA)

2015/06/30 追記:
URL Shortener APIもAPIキーが必要になったようです。キーの取得方法はコチラの記事で解説しています。

 

Google URL Shortener APIを使って短縮URLを取得するコードです。
APIキーの利用が推奨されているので、キーをお持ちの場合はurl部分を変更してください。

Option Explicit

Public Sub Sample()
  Debug.Print GetShortenedLinkGoogl("http://www.ka-net.org/")
End Sub

Public Function GetShortenedLinkGoogl(ByVal target As String) As String
'Google URL Shortenerで短縮URL取得
  Dim dat As Variant
  Dim ret As String
  Const url As String = "https://www.googleapis.com/urlshortener/v1/url"
  'Const url As String = "https://www.googleapis.com/urlshortener/v1/url?key=<API Key>" 'APIキーがある場合
  
  dat = "{""longUrl"": """ & target & """}"
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "POST", url, False
    .setRequestHeader "Content-Type", "application/json; charset=UTF-8"
    .Send dat
    ret = .responseText
  End With
  On Error GoTo 0
  If Len(ret) < 1 Then Exit Function
  
  GetShortenedLinkGoogl = GetGooglLinkID(ret)
End Function

Private Function GetGooglLinkID(ByVal js As String) As String
'JSONデータから短縮URL(id)取得
  Dim d As Object
  Dim elm As Object
    
  js = "(" & js & ")"
  Set d = CreateObject("htmlfile")
  Set elm = d.createElement("span")
  elm.setAttribute "id", "result"
  d.appendChild elm
  d.parentWindow.execScript "document.getElementById('result').innerText=eval(" & js & ").id;"
  
  GetGooglLinkID = elm.innerText
End Function