[转]直接使用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, "<", "<")
' Command = Replace(Command, ">", "&rt;")
' Command = Replace(Command, "&", "&")

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