Excel から REST API を経由して Wagby を操作する [1] 基本形

Sub sample()
  '--------------------------------------------------------------------
  '  変数定義
  '--------------------------------------------------------------------
  Dim objHttpReq As Object          ' XMLHTTP オブジェクト
  Dim strJSON As String             ' レスポンスで受け取るJSONデータ
  Dim strURL As String              ' アクセス先URL
  Dim objJSON As Object             ' レスポンスの JSON 文字列をパースした情報を格納
  '------------------------------------------------------------------
  ' 検索文字付きURLを作成する
  '------------------------------------------------------------------
  strURL = "http://localhost:8921/wagby/rest/customer/entry/" & Range("C2").value
  '------------------------------------------------------------------
  ' XMLHTTP オブジェクトを生成する
  '------------------------------------------------------------------
  Set objHttpReq = CreateObject("MSXML2.XMLHTTP")
  objHttpReq.Open "GET", strURL, False
  '------------------------------------------------------------------
  ' XMLHTTP のリクエストヘッダーを指定する
  '------------------------------------------------------------------
  ' ログイン認証
  objHttpReq.setRequestHeader "X-Wagby-Authorization", "YWRtaW46YWRtaW4="
  'ドメイン名：ポート番号
  objHttpReq.setRequestHeader "Host", "localhost" + ":8921"
  'キャッシュ対策（常にレスポンスが取得できる状態にする）
  objHttpReq.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
  'REST API Version
  objHttpReq.setRequestHeader "X-Wagby-RESTAPIVersion", "v2"
  '------------------------------------------------------------------
  ' リクエストを送信する
  '------------------------------------------------------------------
  objHttpReq.send (Null)
  '------------------------------------------------------------------
  ' レスポンスを取得する
  '------------------------------------------------------------------
  'レスポンス情報を変数に格納する
  strJSON = objHttpReq.responseText
  'MsgBox (strJSON)
    'レスポンスで取得したJSONをパース
    Set objJSON = parseJSON(strJSON)
  If IsNull(objJSON.Item("entity")) Then
    Range("C4").value = "No data."
    Range("C5").ClearContents
    Range("C6").ClearContents
    Range("C7").ClearContents
  Else
    'Call DumpJSONObj(objJSON)
    '取得したレコードからフィールドの値を取得
    Dim entity As Object
    Set entity = objJSON.Item("entity")
    Debug.Print entity.Item("customerid") & vbCrLf;
    Debug.Print entity.Item("customername") & vbCrLf;
    Debug.Print entity.Item("customerkana") & vbCrLf;
    Debug.Print entity.Item("companyname") & vbCrLf;
    Debug.Print entity.Item("tel_") & vbCrLf;
    Range("C4").value = entity.Item("customername")
    Range("C5").value = entity.Item("customerkana")
    Range("C6").value = entity.Item("companyname")
    Range("C7").value = entity.Item("tel")
  End If
End Sub
Sub clear()
  Range("C2").ClearContents
  Range("C4").ClearContents
  Range("C5").ClearContents
  Range("C6").ClearContents
  Range("C7").ClearContents
  Range("C2").Activate
End Sub
'--------------------------------------
'JSONをパースしたオブジェクトを生成
'--------------------------------------
Public Function parseJSON(strJSON As String) As Object
  Dim lib As New JSONLib 'Instantiate JSON class object
  '------------------------------------------------------------------
  ' パースした内容を objJSON 変数に格納する
  '------------------------------------------------------------------
  Set parseJSON = lib.parse(CStr(strJSON))
End Function
Private Sub DumpJSONObj(ByRef json As Variant)
    If TypeName(json) = "Dictionary" Then
        Call DumpDictionaly(json)
    ElseIf TypeName(json) = "Collection" Then
        Call DumpCollection(json)
    Else
        Debug.Print "value:" & json
    End If
End Sub
Public Sub DumpCollection(ByRef dic As Variant)
    Dim keys
    Dim i
    For i = 0 To dic.Count - 1
        Debug.Print "ArrayNo:" & i
        Call DumpJSONObj(dic.Item(i + 1))
    Next i
End Sub
Public Sub DumpDictionaly(ByRef dic As Variant)
    Dim keys
    Dim i
    keys = dic.keys
    For i = 0 To dic.Count - 1
        Dim key
        key = keys(i)
        Debug.Print "key:" & key
        Call DumpJSONObj(dic.Item(key))
    Next i
End Sub