'Option Explicit

'--------------------------------------------------------------------------------
' HTTP通信用クラス。
'--------------------------------------------------------------------------------

' HTTP通信用オブジェクト
Private httpObj As Object

'--------------------------------------------------------------------------------
' コンストラクタ
'--------------------------------------------------------------------------------
Public Sub Class_Initialize()
    Set httpObj = CreateObject("MSXML2.ServerXMLHTTP")    ' TLS1.2に対応
End Sub
Print
'--------------------------------------------------------------------------------
' デストラクタ
'--------------------------------------------------------------------------------
Public Sub Class_Terminate()
    Set httpObj = Nothing
End Sub
Print
'--------------------------------------------------------------------------------
' 引数のURLにPostメソッドで送信する。
'
' url：URL文字列。
' urlParams：URLパラメーター。
' return：レスポンスの文字列。
'--------------------------------------------------------------------------------
Public Function PostContents(url As String, urlParams As String) As String
    Dim buf As String
    Dim httpObj As Object
    Set httpObj = CreateObject("MSXML2.ServerXMLHTTP")    ' TLS1.2に対応
    httpObj.Open "POST", url, False
    httpObj.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    httpObj.send (urlParams)

    ' readyState=4で読み込みが完了
    Do While httpObj.readyState < 4
        DoEvents
    Loop

    Dim statusCode As Integer
    statusCode = httpObj.Status

    ' HTTPのステータスコードが200(OK)以外であれば、ステータスコードなどを返す。
    If (statusCode = 200) Then
        'PostContents = httpObj.responseText ' レスポンスの文字コードがShift_JIS(MS932)の時はこちらを使う。
        'PostContents = StrConv(httpObj.responsebody, vbUnicode)
        Set stm = CreateObject("ADODB.Stream")
        stm.Type = 1   'バイナリモード
        stm.Open
        stm.Write httpObj.responseBody  'バイナリを書き込み
        stm.Position = 0  '先頭に戻してから
        stm.Type = 2   'テキストモードに変更
        stm.Charset = "utf-8"
        strResult = stm.ReadText(-1)   'データ全体を読み込む
        stm.Close
        'MsgBox strResult
        
        '国を切り出す
        buf = InStr(strResult, "Country:")
        buf2 = InStr(buf, strResult, "（")
        buf3 = InStr(buf2, strResult, "）")
        
        
        PostContents = Mid(strResult, buf2 + 1, buf3 - buf2 - 1)
    Else
        buf = "HTTP StatusCode:" & statusCode & ", HTTP StatusText:" & httpObj.statusText
        PostContents = buf
    End If
End Function



Public Function PostContents_new(url As String, urlParams As String) As String
    Dim buf As String
    Dim httpObj As Object
    Dim strResult As Variant
    
    Set httpObj = CreateObject("MSXML2.ServerXMLHTTP")    ' TLS1.2に対応
    httpObj.Open "POST", url, False
    httpObj.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
   httpObj.send ("inServer=" & urlParams)
    'httpObj.send (urlParams)

    ' readyState=4で読み込みが完了
    Do While httpObj.readyState < 4
        DoEvents
    Loop

    Dim statusCode As Integer
    statusCode = httpObj.Status

    ' HTTPのステータスコードが200(OK)以外であれば、ステータスコードなどを返す。
    If (statusCode = 200) Then
        'PostContents = httpObj.responseText ' レスポンスの文字コードがShift_JIS(MS932)の時はこちらを使う。
        'PostContents = StrConv(httpObj.responsebody, vbUnicode)
        Set stm = CreateObject("ADODB.Stream")
        stm.Type = 1   'バイナリモード
        stm.Open
        stm.Write httpObj.responseBody  'バイナリを書き込み
        stm.Position = 0  '先頭に戻してから
        stm.Type = 2   'テキストモードに変更
        stm.Charset = "utf-8"
        strResult = stm.ReadText(-1)   'データ全体を読み込む
        stm.Close
        'MsgBox strResult
        Debug.Print Len(strResult)
        
        '国を切り出す
        buf = InStr(strResult, "Country")
        If buf = 0 Then
            buf = InStr(strResult, "country")
        End If
            
        buf2 = InStr(buf, strResult, "（")
        buf3 = InStr(buf2, strResult, "）")
        
        
       PostContents_new = Mid(strResult, buf2 + 1, buf3 - buf2 - 1)
       'PostContents_new = strResult
    Else
        buf = "HTTP StatusCode:" & statusCode & ", HTTP StatusText:" & httpObj.statusText
        PostContents_new = buf
    End If
End Function