وب سرویس

[amirzazadeh]

مرحله اول مهم نیست که User/pass واقعی داشته باشیم، همین که پروسه ارسال و دریافت پیغام خطا انجام بشه کافی هست.
بفرمایید که شما با کدی که پیوست کردین جواب گرفتین؟

با سپاس از دوست گرامي جناب 336699 بله به صورت كامل ارسال و دريافت صورت مي گيره.

[mazoolagh]

همین چند خط زیر برای ارسال درخواست کافی هست:

Const WSURL As String = "http://webapi.ihio.gov.ir/erx-core/v1/service/auth/token/fetch"

Const AuthJSON As String = "{""terminalId"": 123456,""userName"": ""test_username"",""password"": ""test_password""}"



Dim Request As New MSXML2.XMLHTTP60



With Request

    .Open "POST", WSURL, False

    .SetRequestHeader "Host", "webapi.ihio.gov.ir"

    .SetRequestHeader "Content-Type", "application/json; charset=utf-8"

    .Send AuthJSON

End With

و پاسخ خام رو در responseText خواهیم داشت.

[mazoolagh]

'-------------------------------------------------------------------' 

VBA JSON Parser

'-------------------------------------------------------------------

Option Explicit

Private p As Integer, token, dic



Function ParseJSON(json As String, Optional key As String = "obj") As Dictionary

    p = 1

    token = Tokenize(json)

    Set dic = New Dictionary

    If token(p) = "{" Then ParseObj key Else ParseArr key

    Set ParseJSON = dic

End Function



Function ParseObj(key As String)

    Do: p = p + 1

        Select Case token(p)

            Case "]"

            Case "[":  ParseArr key

            Case "{":  ParseObj key

            Case "{"

                       If token(p + 1) = "}" Then

                           p = p + 1

                           dic.Add key, "null"

                       Else

                           ParseObj key

                       End If

                

            Case "}":  key = ReducePath(key): Exit Do

            Case ":":  key = key & "." & token(p - 1)

            Case ",":  key = ReducePath(key)

            Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)

        End Select

    Loop

End Function



Function ParseArr(key As String)

    Dim e As Integer

    Do: p = p + 1

        Select Case token(p)

            Case "}"

            Case "{":  ParseObj key & ArrayID(Val(e))

            Case "[":  ParseArr key

            Case "]":  Exit Do

            Case ":":  key = key & ArrayID(Val(e))

            Case ",":  e = e + 1

            Case Else: dic.Add key & ArrayID(Val(e)), token(p)

        End Select

    Loop

End Function

'-------------------------------------------------------------------

' Support Functions

'-------------------------------------------------------------------

Function Tokenize(s As String)

    Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|[^\s""']+?"

    Tokenize = RExtract(s, Pattern, True)

End Function



Function RExtract(s As String, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)

  Dim c As Integer, m, n, v

  With CreateObject("vbscript.regexp")

    .Global = bGlobal

    .MultiLine = False

    .IgnoreCase = True

    .Pattern = Pattern

    If .TEST(s) Then

      Set m = .Execute(s)

      ReDim v(1 To m.Count)

      For Each n In m

        c = c + 1

        v(c) = n.Value

        If bGroup1Bias Then If Len(n.submatches(0)) Or n.Value = """""" Then v(c) = n.submatches(0)

      Next

    End If

  End With

  RExtract = v

End Function



Function ArrayID(e As String) As String

    ArrayID = "(" & e & ")"

End Function



Function ReducePath(key As String) As String

    If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1) Else ReducePath = key

End Function