何年か前にHPで「goo.glで短縮URLを取得する」マクロを紹介しました。

人力検索はてなに「長い複数のURLを一度に短縮する方法はないでしょうか」という質問があり、上記記事へのリンクが貼られていたのですが、質問者さんの環境では実行できていないようでした。

私の方でも試してみたのですが、たしかに短縮URLが取得できなくなっています。

そこで、通信時のレスポンスを調べてみると、403エラー(Daily Limit for Unauthenticated Use Exceeded. Continued use requires signup.)が返ってきていました。
非承認時の上限超えのようです。いつの間にかURL Shortener APIもAPIキーが必要になっていたみたいですね。

ならば話は簡単で、APIキーを含めてリクエストを投げてやれば良さそうです。

Google APIキーの取得方法

※ 要Google アカウント

1. Google アカウントでログインした状態で「Google Developers Console」にアクセスします。
2. 「プロジェクトの作成」ボタンをクリックします。



3. プロジェクト名を適当に入力し「作成」ボタンをクリックします。



4. プロジェクトが作成されたら「APIと認証」から「API」をクリックします。



5. 検索ボックスに「URL」と入力し、ヒットした「URL Shortener API」をクリックします。



6. URL Shortener API画面が開かれたら「APIを有効にする」ボタンをクリックします。





7. APIが有効になったら「APIと認証」から「認証情報」をクリックします。



8. 認証情報画面が開かれたら「公開 API へのアクセス」から「新しいキーを作成」ボタンをクリックします。



9. 新しいキーの作成ダイアログが表示されたら「ブラウザキー」ボタンをクリックします。



10. ブラウザキーの作成と許可対象リファラーの設定ダイアログが表示されたらテキストエリアを空欄にしたまま「作成」ボタンをクリックします。



11. APIキーが作成されたら、表示された「API キー」をメモ帳にでもコピーしておきます。

これでAPIキーを入手することができました。
あとはVBAコード(上で紹介している記事のコードから若干変更しました)にAPIキーを入れてやればマクロ完成です。

'標準モジュール
Public Function GetShortenURL(ByVal TargetURL As String) As String
'Google URL Shortener APIを使って短縮URLを取得
  Dim dat As Variant
  Dim js As String, ret As String
  Dim d As Object, elm As Object
  Const API_KEY As String = "(APIキー)"
  
  js = "": ret = "" '初期化
  dat = "{""longUrl"": """ & TargetURL & """}"
  With CreateObject("WinHttp.WinHttpRequest.5.1")
    .Open "POST", "https://www.googleapis.com/urlshortener/v1/url?key=" & API_KEY, False
    .SetRequestHeader "Content-Type", "application/json"
    .Send dat
    Select Case .Status
      Case 200: js = .ResponseText
      Case Else: ret = "Error:" & .Status
    End Select
  End With
  If Len(Trim(js)) > 0 Then
    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;"
    ret = elm.innerText
  End If
  GetShortenURL = ret
End Function

上記コードは標準モジュールに書くと、ワークシート上からも呼び出せて便利だと思います。