- 追加された行はこの色です。
- 削除された行はこの色です。
VBAでREST通信をする際のコードを各種サイトのコードを自分がわかりやすいようにまとめた。
Option Explicit
'--------------------------------------------------------------------------------
' HTTP通信用クラス。
' 依存:
' GitHubの下記Dictionaryクラスをbasファイルとしてプロジェクト内に入れておく
' https://github.com/timhall/VBA-Dictionary
' 使用例:
' パラメータの設定は、以下のようにしてsendメソッドの引数に入れる
' Dim apiHeaders As Dictionary
' apiHeaders.Add "Authorization", "Basic " & base64Credentials
' apiHeaders.Add "Accept", "application/json"
' apiHeaders.Add "Content-Type", "application/json"
' 動作確認:
' 以下のサイトがありがたい
' http://httpbin.org
'--------------------------------------------------------------------------------
' HTTP通信用オブジェクト
Private httpObj As Object
'--------------------------------------------------------------------------------
' コンストラクタ
'--------------------------------------------------------------------------------
Public Sub Class_Initialize()
Set httpObj = CreateObject("MSXML2.ServerXMLHTTP") ' TLS1.2に対応
End Sub
'--------------------------------------------------------------------------------
' デストラクタ
'--------------------------------------------------------------------------------
Public Sub Class_Terminate()
Set httpObj = Nothing
End Sub
'--------------------------------------------------------------------------------
' 引数のURLに指定メソッドで送信する。
'
' method : GET POST PATCH
' url：URL文字列
' urlParams：URLパラメーター
' headers: リクエストヘッダ
' return：レスポンスの文字列をJson解析したオブジェクト
'--------------------------------------------------------------------------------
Public Function send(method As String, url As String, urlParams As String, Optional ByVal headers As Dictionary = Null) As Object
httpObj.Open method, url, False
' リクエストヘッダー設定
Dim i As Long
For i = 0 To headers.Count - 1
httpObj.setRequestHeader headers.Keys(i), headers.Items(i)
Next i
httpObj.send (urlParams)
' readyState=4: 読み込み完了
Do While httpObj.readyState < 4
DoEvents
Loop
Dim statusCode As Integer
statusCode = httpObj.Status
If (statusCode = 200) Then
Debug.Print "200:OK"
'PostContents = httpObj.responseText ' レスポンスの文字コードがShift_JIS(MS932)の時はこちらを使う。
'PostContents = StrConv(httpObj.responsebody, vbUnicode)
' レスポンスの文字列（objHTTP.responseText）をJsonに変換して返却
Debug.Print "---------------"
Debug.Print httpObj.responseText
Dim responsJson As Object
Set responsJson = JsonConverter.ParseJson(httpObj.responseText)
responsJson("HTTP StatusCode") = 200
Set send = responsJson
Else
Set send = JsonConverter.ParseJson("{""HTTP StatusCode"" : """ & statusCode & """, ""HTTP StatusText"" : """ & httpObj.statusText & """}")
End If
End Function
