Excel VBA で JSON が扱いたいときは VBA-JSON が便利

excel

VBA で JSON を扱うことができる VBA-JSON が便利だったのでメモ。

VBA-tools/VBA-JSON: JSON conversion and parsing for VBA

JSON conversion and parsing for VBA (Windows and Mac Excel, Access, and other Office applications). It grew out of the excellent project vba-json, with additions and improvements made to resolve bugs and improve performance (as part of VBA-Web).

今回はサンプルとして openBD の API を叩いて、ISBN から書名、著者名、出版日、出版社名、価格を取得するコードを書いてみました。
以下のように非常にシンプルなコードで実現できます。
実行方法は適当なセルに ISBN を入力し、その範囲を選択した状態でマクロを実行するだけです。日本語も問題なく取れていますね。

Option Explicit

Sub Main()
    Dim i As Long
    Dim c As Range
    For i = Selection(1).row To Selection(Selection.Count).row
        Set c = Selection(1).Offset(i - 1, 0)
        If c.Value = "" Then
           Exit For
        Else
            Search c.Value, c
        End If
    Next
    For i = 0 To 5
            c.Offset(0, i).EntireColumn.AutoFit
    Next
End Sub

Sub Search(ISBN As String, cell As Range)
    If Not ISBN = "" Then
        Dim jsonObj As Object
        Dim Url As String
        Dim Json As String
        Url = "https://api.openbd.jp/v1/get?isbn=" & ISBN
        Json = GetContents(Url)
        Set jsonObj = JsonConverter.ParseJson(Json)
        If jsonObj.Count > 0 Then
            'タイトル
            Dim title As String
            title = jsonObj(1)("summary")("title")
            cell.Offset(0, 1) = title
            '著者
            Dim author As String
            author = jsonObj(1)("summary")("author")
            cell.Offset(0, 2) = author
            '出版日
            Dim pubdate As String
            pubdate = jsonObj(1)("summary")("pubdate")
            cell.Offset(0, 3) = pubdate
            ' 出版社
            Dim publisher As String
            publisher = jsonObj(1)("summary")("publisher")
            cell.Offset(0, 4) = publisher
            ' 価格
            On Error GoTo Catch
            Dim price As Integer
            price = jsonObj(1)("onix")("ProductSupply")("SupplyDetail")("Price")(1)("PriceAmount")
            cell.Offset(0, 5) = price
Catch:
            
        End If
    End If
End Sub

Function GetContents(Url As String) As String
    Dim XmlHttp As Object
    Set XmlHttp = CreateObject("MSXML2.XMLHTTP")
    
    XmlHttp.Open "GET", Url, False
    XmlHttp.Send
    
    GetContents = XmlHttp.ResponseText
End Function