[转]直接使用XML做SOAP请求

'保持属性值的局部变量
Private mvarServerURL As String '局部复制

Public Property Let ServerURL(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.ServerURL = 5
    mvarServerURL = vData
End Property

Public Property Get ServerURL() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.ServerURL
    ServerURL = mvarServerURL
End Property

Public Function ExecuteCommandWithReturn(ByVal Command As String) As String
    Dim safeString As String    '身份验证码
    Dim strXML As String        'SOAP查询
    
    'On Error GoTo Errs:
    On Error Resume Next
    
    
    safeString = LCase(Replace("592672-016767-2CC4F321-0E348AF1-AB52FF57-E07A", "-", ""))
'    Command = Replace(Command, " ", " ")
'    Command = Replace(Command, "'", "'")
'    Command = Replace(Command, """", """)
'    Command = Replace(Command, "<", "&lt;")
'    Command = Replace(Command, ">", "&rt;")
'    Command = Replace(Command, "&", "&amp;")
   
    strXML = strXML & "<?xml version=""1.0"" encoding=""utf-8""?>" & vbCrLf
    strXML = strXML & "<soap:Envelope xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xmlns:xsd=""http://www.w3.org/2001/XMLSchema"" xmlns:soap=""http://schemas.xmlsoap.org/soap/envelope/"">" & vbCrLf
    strXML = strXML & "  <soap:Body>" & vbCrLf
    strXML = strXML & "    <ExecuteCommandWithReturn xmlns=""http://tempuri.org/GPSService/Data"">" & vbCrLf
    strXML = strXML & "      <SafeCode>" & safeString & "</SafeCode>" & vbCrLf
    strXML = strXML & "      <CommandText>" & Command & "</CommandText>" & vbCrLf
    strXML = strXML & "    </ExecuteCommandWithReturn>" & vbCrLf
    strXML = strXML & "  </soap:Body>" & vbCrLf
    strXML = strXML & "</soap:Envelope>"
        
    '定义一个XML HTTP Request对象，用于发送请求
    Dim soapHTTP As New MSXML.XMLHTTPRequest
    
    '定义一个XML的文档对象，将手写的或者接受的XML内容转换成XML对象
    Dim soapXML As New MSXML.DOMDocument
    
    '将手写的SOAP字符串转换为XML对象
    soapXML.loadXML strXML
    
    '向指定的URL发送Post消息
    soapHTTP.open "POST", mvarServerURL & "", False
    soapHTTP.setRequestHeader "Content-Type", "text/xml;charset=utf-8"
    'soapHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; MS Web Services Client Protocol 1.1.4322.2300)"
    soapHTTP.setRequestHeader "SOAPAction", "http://tempuri.org/GPSService/Data/ExecuteCommandWithReturn"
    soapHTTP.send (strXML)
    
    While soapHTTP.readyState <> 4  '等待处理完毕
    Wend
    
    '返回的XML信息
    Dim strReturn As String
    'Debug.Print soapHTTP.responseText
    Dim XMLReturn As MSXML.DOMDocument
    Set XMLReturn = soapHTTP.responseXML
    
    ExecuteCommandWithReturn = XMLReturn.childNodes(1).Text
    Set XMLReturn = Nothing
    Set soapXML = Nothing
    Set soapHTTP = Nothing
    Exit Function
Errs:
    MsgBox Err.Description
    Debug.Print Err.Description
End Function