VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CXMLRPCRequest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Public Sub decodeResponse(ByRef xml As MSXML2.DOMDocument, ByRef argv As Variant, ByRef fault As Boolean)
    Dim nodes As MSXML2.IXMLDOMNodeList
    Dim av As New CAssocItem

    Set nodes = xml.selectNodes("/methodResponse/fault/value/*")

    If nodes.length() > 0 Then
        fault = True
        Set av = decodeData(nodes.item(0))
    Else
        fault = False
        Set nodes = xml.selectNodes("/methodResponse/params/param/value/*")
        
        If nodes.length() > 0 Then
            Set av = decodeData(nodes.item(0))
        Else
            Call Err.Raise(-1, , "Invalid XML response.")
        End If
    End If

    If IsObject(av.value) Then
        Set argv = av.value
    Else
        argv = av.value
    End If

    Set nodes = Nothing
    Set av = Nothing
End Sub

Private Function decodeData(ByRef node As MSXML2.IXMLDOMNode) As CAssocItem
    Dim i As Long
    Dim nodes As MSXML2.IXMLDOMNodeList
    Dim key As String
    Dim value As CAssocItem
    Dim itime As New CInetTime
    Dim b64 As New CBase64
    Dim tmpNode As MSXML2.IXMLDOMNode
    Dim text As String

    Set decodeData = New CAssocItem

    If node.nodeName = "array" Then
        Set nodes = node.selectNodes("data/value")
        Set decodeData.value = New Collection

        For i = 0 To nodes.length() - 1
            Set value = decodeData(nodes.item(i).firstChild)
            Call decodeData.value.Add(value.value)
        Next
    ElseIf node.nodeName = "struct" Then
        Set nodes = node.selectNodes("member")
        Set decodeData.value = New CAssocArray

        For i = 0 To nodes.length() - 1
            key = nodes.item(i).selectSingleNode("name/text()").nodeValue
            Set value = decodeData(nodes.item(i).selectSingleNode("value/*"))
            Call decodeData.value.Add(key, value.value)
        Next
    Else
        Set tmpNode = node.selectSingleNode("text()")

        If tmpNode Is Nothing Then
            text = ""
        Else
            text = tmpNode.nodeValue
        End If

        If node.nodeName = "boolean" Then
            decodeData.value = CBool(CLng(text))
        ElseIf node.nodeName = "int" Or node.nodeName = "i4" Then
            decodeData.value = CLng(text)
        ElseIf node.nodeName = "double" Then
            decodeData.value = CDbl(text)
        ElseIf node.nodeName = "dateTime.iso8601" Then
            decodeData.value = itime.InternetTimeToVbLocalTime(text)
        ElseIf node.nodeName = "base64" Then
            decodeData.value = b64.DecodeBase64(text)
        ElseIf node.nodeName = "string" Then
            decodeData.value = CStr(text)
        Else
            Call Err.Raise("Unknown type.", , -1)
        End If
    End If
End Function

Public Sub encodeRequest(ByVal method As String, ByRef request As Variant, ByRef xml As String)
    Dim src As String
    Dim av As New CAssocItem

    If IsObject(request) Then
        Set av.value = request
    Else
        av.value = request
    End If

    src = "<?xml version=""1.0"" encoding=""utf-8""?>" & _
        "<methodCall>" & _
            "<methodName>" & escapeXMLString(method) & "</methodName>" & _
            "<params><param><value>" & _
                encodeData(av) & _
            "</value></param></params>" & _
        "</methodCall>"

'    Set xml = New MSXML2.DOMDocument
'    Call xml.loadXML(src)
    xml = src
'    Set av = Nothing
End Sub

Private Function encodeData(ByRef item As CAssocItem) As String
    Dim itime As New CInetTime
    Dim av As New CAssocItem
    Dim v As Variant
    Dim b64 As CBase64
    Dim itemType As VariantTypeConstants
    Dim itemObjType As String
    
    itemType = VarType(item.value)
    
    If itemType = vbObject Then
        itemObjType = TypeName(item.value)

        If itemObjType = "CAssocArray" Then
            encodeData = "<struct>"

            For Each av In item.value
                encodeData = encodeData & "<member>" & _
                        "<name>" & escapeXMLString(av.key) & "</name>" & _
                        "<value>" & encodeData(av) & "</value>" & _
                    "</member>"
            Next

            encodeData = encodeData & "</struct>"
        ElseIf itemObjType = "Collection" Then
            encodeData = "<array><data>"

            For Each v In item.value
                av.value = v
                encodeData = encodeData & "<value>" & encodeData(av) & "</value>"
            Next

            encodeData = encodeData & "</data></array>"
        Else
            Call Err.Raise(-1, , "Unsupported object type: " + itemObjType)
        End If
    ElseIf itemType = vbBoolean Then
        encodeData = "<boolean>" & IIf(item.value, "1", "0") & "</boolean>"
    ElseIf itemType = vbInteger Or itemType = vbLong Then
        encodeData = "<i4>" & Trim(CStr(item.value)) & "</i4>"
    ElseIf itemType = vbSingle Or itemType = vbDouble Then
        encodeData = "<double>" & Trim(CStr(item.value)) & "</double>"
    ElseIf itemType = vbDate Then
        encodeData = "<dateTime.iso8601>" & _
            escapeXMLString(itime.VbLocalTimeToInternetTime(item.value, "iso8601")) & _
            "</dateTime.iso8601>"
    ElseIf itemType = vbString Or itemType = vbCurrency Or itemType = vbDecimal Then
        encodeData = "<string>" & escapeXMLString(item.value) & "</string>"
'    ElseIf itemType = vbByte + vbArray Then
'        encodeData = b64.EncodeBase64(item.value)
'' !!!!!!!!! Base64 not supported
    Else
        Call Err.Raise(-1, , "Unknown type: " + CStr(itemType))
    End If

    Set v = Nothing
End Function

Private Function escapeXMLString(str As String)
    str = Replace(str, "&", "&amp;")
    str = Replace(str, "<", "&lt;")
    str = Replace(str, ">", "&gt;")
    str = Replace(str, Chr(34), "&quot;")
    escapeXMLString = Replace(str, "'", "&apos;")
End Function

Public Function doCall(url As String, method As String, ByRef params As Variant, ByRef result As Variant) As Boolean
    Dim http As New MSXML2.ServerXMLHTTP60
    Dim xml As String

    If Not IsObject(params) And VarType(params) = vbEmpty Then
        params = ""
    End If

    Call encodeRequest(method, params, xml)
    Call http.Open("POST", url, False)
    Call http.send(xml)
    ' Настраивайте прокси, если нужно. По умолчанию работает без прокси!

    If http.Status <> 200 Then
        Set http = Nothing
        doCall = False
        Call Err.Raise(-1, , "Ошибка зароса на сервер XML-RPC.")
    End If

    Call decodeResponse(http.responseXML, result, doCall)
    Set http = Nothing
End Function