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.body.appendChild elm

                      d.parentWindow.execScript "document.getElementById('result').innerText=eval(" & js & ").id;"

                      

                      GetGooglLinkID = elm.innerText

                    End Function