HOME [MENU]

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "RestClient"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' RestClient v1.0
'
' (c) COOL MAGIC TOKYO - https://coolmagic.guy.jp/computer/download/index_en.html
' 0-clause BSD license included below
'
'---------------------------------------------------------------------------------
' Copyright (C) 2023 by "COOL MAGIC TOKYO" shop@coolmagic.guy.jp
'
' Permission to use, copy, modify, and/or distribute this software for any purpose
' with or without fee is hereby granted.
'
' THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
' REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
' FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
' INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
' OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
' TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
' THIS SOFTWARE.

Option Explicit

Private httpObj As Object   '�uMicrosoft XML, v6.0�v���Q�Ɛݒ�
Private statusCode

Public contentType
Public url
Public proxyHost
Public credentialUser
Public credentialPassword

Public Sub Class_Initialize()
    Set httpObj = CreateObject("MSXML2.ServerXMLHTTP")    ' TLS1.2�ɑΉ�
    contentType = "application/json"
    proxyHost = ""
    credentialUser = ""
    credentialPassword = ""
    statusCode = 0
    
End Sub

Public Sub Class_Terminate()
    Set httpObj = Nothing

End Sub

'--------------------------------------------------------------------------------
'   RequestPost
'
Public Function RequestPost(urlParams As Object) As Object
    On Error GoTo RequestPostError
    
    Set RequestPost = Nothing
    statusCode = 0

    httpObj.Open "POST", url, False
    SetProxy
    httpObj.setRequestHeader "Content-Type", contentType
    httpObj.send (JsonConverter.ConvertToJson(urlParams))

    Do While httpObj.readyState < 4
        DoEvents
    Loop

    statusCode = httpObj.status

    If statusCode <> 200 Then Exit Function
    Set RequestPost = JsonConverter.ParseJson(StrConv(httpObj.responseBody, vbUnicode))
    
RequestPostError:
    If Err <> 0 Then MsgBox Error(Err), vbExclamation, "PostContentsError"
    On Error Resume Next
    Err.Clear
    Exit Function
    
End Function

'--------------------------------------------------------------------------------
'   RequestGet
'
Public Function RequestGet(Optional urlParams As Object = Null) As Object
    On Error GoTo RequestGetError
    
    Set RequestGet = Nothing
    statusCode = 0

    Dim strUrl
    strUrl = url
    If Not IsNull(urlParams) And (urlParams Is Nothing) = False Then
        strUrl = strUrl & "?" & encodeParams(urlParams)
    End If
    httpObj.Open "GET", strUrl
    SetProxy
    httpObj.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    httpObj.send

    ' readyState=4�œǂݍ��݂�����
    Do While httpObj.readyState < 4
        DoEvents
    Loop

    statusCode = httpObj.status

    If statusCode <> 200 Then Exit Function
    Set RequestGet = JsonConverter.ParseJson(StrConv(httpObj.responseBody, vbUnicode))

RequestGetError:
    If Err <> 0 Then MsgBox Error(Err), vbExclamation, "GetContentsError"
    On Error Resume Next
    Err.Clear
    Exit Function

End Function

'--------------------------------------------------------------------------------
'   encodeParams
'
Private Function encodeParams(pDic As Dictionary)
    On Error GoTo encodeParamsError
    
    Dim ary() As String
    ReDim ary(pDic.Count - 1) As String

    Dim i As Long
    For i = 0 To pDic.Count - 1
        ary(i) = pDic.Keys(i) & "=" & Application.WorksheetFunction.EncodeURL(pDic.Items(i))
    Next i

    encodeParams = Join(ary, "&")
    
encodeParamsError:
    If Err <> 0 Then MsgBox Error(Err), vbExclamation, "encodeParamsError"
    On Error Resume Next
    Err.Clear
    Exit Function

End Function

'--------------------------------------------------------------------------------
'   setProxy
'
Private Sub SetProxy()
    If Len(proxyHost) > 0 Then
        httpObj.SetProxy 2, proxyHost
    End If
    If Len(credentialUser) > 0 And Len(credentialPassword) > 0 Then
        httpObj.setProxyCredentials credentialUser, credentialPassword
    End If

End Sub

'--------------------------------------------------------------------------------
'   GetStatus
'
Public Function GetStatus()
    GetStatus = statusCode

End Function
 

Return

HOME [MENU]