Instagram APIをVBAから呼び出してみる。

ホーム
Office関連, Excel
Instagram APIをVBAから呼び出してみる。

Office関連

2016.05.6

Instagram APIをVBAから呼び出してみる。

最近画像共有系のSNS、Instagram(インスタグラム)を使い始めました。

このサービスも他のSNSと同様にAPIが用意されているので、さっそくVBAから使ってみたいと思います。

Client ID他の取得

APIを利用するにはClient IDやClient Secretといった情報が必要になるので、まずは開発者向けサイトから必要な情報を取得します。

「Manage Clients」をクリックし、WebサイトのURLや電話番号と言った項目を入力し、「Sign up」ボタンをクリックします。

InstagramAPI_01

Manage Clients画面が表示されたら「Register a New Client」ボタンをクリックします。

InstagramAPI_02

アプリケーション名などの項目を入力し、「Register」ボタンをクリックします。

InstagramAPI_03

登録が無事に終わると、Client IDやClient Secretが表示されるので、メモ帳にでも控えておきます。

InstagramAPI_04

VBAからの呼び出し

準備ができたら、いよいよAPIの呼び出しです。
InstagramのAPIもMicrosoft GraphなどのAPIと同様、

code(authorization)取得
↓
access token取得
↓
エンドポイントにリクエストを投げて結果を取得

といった利用手順になっています。
下記コードでは「/users/self/media/recent」にリクエストを投げ、返ってきた結果から画像ファイルだけを指定フォルダーに保存する処理を行います。

Option Explicit

Public Sub SampleInstagramAPI()
'サンプル - Instagram API呼び出し
'※ ScriptControlを使っているため、32ビット環境のみ対応
'※ リダイレクト URIをlocalhostにしている場合は、ローカルサーバー(XAMPP他)の起動が必要な場合があります。
  Dim url_auth As String
  Dim url_token As String
  Dim url_api As String
  Dim url As String
  Dim q As String
  Dim code As String
  Dim js As String
  Dim access_token As String
  Dim dat As Variant
  Dim ary As Variant, ary2 As Variant
  Dim item As Object, items As Object
  Dim images As Object
  Dim fol As String
  Dim file As String
  Dim v As Variant
  Dim i As Long
  Dim data, [type], standard_resolution 'JSONパース用ダミー
  Const READYSTATE_COMPLETE = 4
  
  '**********************************************************************
  'クライアント ID, クライアント シークレット, リダイレクト URI
  Const client_id As String = "(クライアント ID)"
  Const client_secret As String = "(クライアント シークレット)"
  Const redirect_uri As String = "(リダイレクト URI)"
  '**********************************************************************
  
  '画像ファイルの保存先選択
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "画像ファイルの保存先フォルダーを選択してください。"
    .AllowMultiSelect = False
    .InitialFileName = CreateObject("Shell.Application") _
      .Namespace(0).Self.Path & Application.PathSeparator 'デスクトップ
    If .Show = True Then
      fol = .SelectedItems(1)
    Else
      Exit Sub
    End If
  End With
  fol = AddPathSeparator(fol)
  
  'authorization code取得
  code = "" '初期化
  url_auth = "https://api.instagram.com/oauth/authorize/?response_type=code" & _
             "&redirect_uri=" & EncodeURL(redirect_uri) & _
             "&client_id=" & client_id
  With CreateObject("InternetExplorer.Application")
    .Visible = True
    .AddressBar = False
    .MenuBar = False
    .StatusBar = False
    .Toolbar = False
    .Width = 600
    .Height = 480
    .Navigate url_auth
    While .ReadyState <> READYSTATE_COMPLETE Or _
          .Busy = True Or _
          (StrComp(Left(.LocationURL, Len(redirect_uri)), redirect_uri) <> 0)
      DoEvents
    Wend
    q = .document.parentWindow.Location.Search
    q = Mid(q, 2) '"?"削除
    ary = Split(q, "&")
    For i = LBound(ary) To UBound(ary)
      ary2 = Split(ary(i), "=")
      If LCase(ary2(0)) = "code" Then
        code = ary2(1)
        Exit For
      End If
    Next
    .Quit
  End With
  If Len(Trim(code)) < 1 Then Exit Sub
  
  'access token取得
  js = "": access_token = "" '初期化
  url_token = "https://api.instagram.com/oauth/access_token"
  dat = "grant_type=authorization_code" & _
        "&code=" & code & _
        "&client_id=" & client_id & _
        "&client_secret=" & client_secret & _
        "&redirect_uri=" & EncodeURL(redirect_uri)
  With CreateObject("WinHttp.WinHttpRequest.5.1")
    .Open "POST", url_token, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .send dat
    Select Case .Status
      Case 200: js = .responseText
    End Select
  End With
  If Len(Trim(js)) < 1 Then Exit Sub
  js = "(" & js & ")"
  With CreateObject("ScriptControl")
    .Language = "JScript"
    access_token = .CodeObject.eval(js).access_token
  End With
  If Len(Trim(access_token)) < 1 Then Exit Sub

  'Instagram APIを呼び出して画像ファイル保存
  js = "" '初期化
  url_api = "https://api.instagram.com/v1/users/self/media/recent/?access_token=" & access_token
  With CreateObject("WinHttp.WinHttpRequest.5.1")
    .Open "GET", url_api, False
    .send
    Select Case .Status
      Case 200: js = .responseText
    End Select
  End With
  If Len(Trim(js)) < 1 Then Exit Sub
  js = "(" & js & ")"
  With CreateObject("ScriptControl")
    .Language = "JScript"
    Set items = .CodeObject.eval(js).data
    For Each item In items
      Select Case item.type
        Case "image" '画像のみ処理
          Set images = item.images
          url = images.standard_resolution.url
          v = Split(url, "/")
          file = LCase(v(UBound(v)))
          file = Left(file, InStr(file, ".jpg") + 3)
          DownloadFile url, fol & file
      End Select
    Next
  End With
  
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Private Sub DownloadFile(ByVal url As String, ByVal SaveFilePath As String)
  Dim req As Object
  Const adTypeBinary = 1
  Const adSaveCreateOverWrite = 2
  
  Set req = Nothing '初期化
  Set req = CreateObject("WinHttp.WinHttpRequest.5.1")
  If req Is Nothing Then Exit Sub
  req.Open "GET", url, False
  req.send
  Select Case req.Status
    Case 200
      With CreateObject("ADODB.Stream")
        .type = adTypeBinary
        .Open
        .Write req.responseBody
        .SaveToFile SaveFilePath, adSaveCreateOverWrite
        .Close
      End With
    Case Else
      MsgBox "エラーが発生しました。" & vbCrLf & _
             "ステータスコード：" & req.Status, _
             vbCritical + vbSystemModal
      Exit Sub
  End Select
End Sub

Private Function EncodeURL(ByVal Target As String) As String
'URLエンコード
  With CreateObject("ScriptControl")
    .Language = "JScript"
    EncodeURL = .CodeObject.encodeURIComponent(Target)
  End With
End Function

Private Function AddPathSeparator(ByVal s As String) As String
  If Right(s, 1) <> ChrW(92) Then s = s & ChrW(92)
  AddPathSeparator = s
End Function