VBA或VB6调用WebService（直接Post方式）并解析返回的XML

VBA或VB6调用WebService（直接Post方式）并解析返回的XML，理论上Access也是可以使用的

Function TodoTaskBySOAP(postURL As String,host As String, n As Integer,FilterItem() As String,OwnerSSICID() As String ,AppID() As String ,ToDoID() As String,Title() As String,Url() As String ,ExpireDate() As String,CreateTime() As String, Action() As String ,UpdateTime() As String ,Remark1() As String,Remark2() As String,Remark3() As String) As String 
 
	On Error GoTo ErrSub	
	Dim oXMLHttp As Variant
 
	Dim errcode As String 
	Dim errmsg As String 
	Dim postData As String
	Dim responseText As String
	Dim resStr As String
	Dim sXML As String
	Dim i As integer
	Dim oXML As Variant
	Set oXMLHttp = CreateObject("Msxml2.XMLHTTP") 
	
	Dim objNodes As Variant
	Dim nodeValues As Variant
	
	If Not IsObject(oXMLHttp) Then
		Set oXMLHttp = CreateObject("Microsoft.XMLHTTP")
		If Not IsObject(oXMLHttp) Then
			MsgBox "缺少Msxml组件!",0 + 64,"错误"
			Exit Function
		End If
	End If
	
	If UBound(FilterItem) = n And UBound(OwnerSSICID)= n And UBound(AppID)=n And UBound(ToDoID)=n And UBound(Title)=n And UBound(Url)=n And UBound(ExpireDate)=n And UBound(CreateTime)=n  And UBound(Action)=n And UBound(UpdateTime)=n  And UBound(Remark1)=n And UBound(Remark2)=n And UBound(Remark3)=n Then 
		postData = "<?xml version=""1.0"" encoding=""utf-8""?>"
		postData = postData & "<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/"">"
		postData = postData & "<soap:Body>"
		postData = postData & "<SaveToDo xmlns=""http://webservice.iipa/"">"
		
		postData = postData & "<n>"& n &"</n>"
		
		postData = postData + "<FilterItem>"
		For i = 0 To n -1
			postData = postData &"<string>" & FilterItem(i) &"</string>"
		Next
		postData = postData + "</FilterItem>"
		
		postData = postData + "<OwnerSSICID>"
		For i = 0 To n -1
			postData = postData &"<string>" & OwnerSSICID(i) &"</string>"
		Next
		postData = postData + "</OwnerSSICID>"
		
		postData = postData + "<AppID>"
		For i = 0 To n -1
			postData = postData &"<int>" & AppID(i) &"</int>"
		Next
		postData = postData + "</AppID>"
		
		postData = postData + "<ToDoID>"
		For i = 0 To n -1
			postData = postData &"<string>" & ToDoID(i) &"</string>"
		Next
		postData = postData + "</ToDoID>"
		
		postData = postData + "<Title>"
		For i = 0 To n -1
			postData = postData &"<string>" & Title(i) &"</string>"
		Next
		postData = postData + "</Title>"
		
		postData = postData + "<Url>"
		For i = 0 To n -1
			postData = postData &"<string>" & Url(i) &"</string>"
		Next
		postData = postData + "</Url>"
		
		postData = postData + "<ExpireDate>"
		For i = 0 To n -1
			postData = postData &"<string>" & ExpireDate(i) &"</string>"
		Next
		postData = postData + "</ExpireDate>"
		
		postData = postData + "<CreateTime>"
		For i = 0 To n -1
			postData = postData &"<string>" & CreateTime(i) &"</string>"
		Next
		postData = postData + "</CreateTime>"
		
		postData = postData + "<Action>"
		For i = 0 To n -1
			postData = postData &"<int>" & Action(i) &"</int>"
		Next
		postData = postData + "</Action>"
		
		postData = postData + "<UpdateTime>"
		For i = 0 To n -1
			postData = postData &"<string>" & UpdateTime(i) &"</string>"
		Next
		postData = postData + "</UpdateTime>"
		
		postData = postData + "<Remark1>"
		For i = 0 To n -1
			postData = postData &"<string>" & Remark1(i) &"</string>"
		Next
		postData = postData + "</Remark1>"
		
		postData = postData + "<Remark2>"
		For i = 0 To n -1
			postData = postData &"<string>" & Remark2(i) &"</string>"
		Next
		postData = postData + "</Remark2>"
		
		postData = postData + "<Remark3>"
		For i = 0 To n -1
			postData = postData &"<string>" & Remark3(i) &"</string>"
		Next
		postData = postData + "</Remark3>"
		
		postData = postData + "</SaveToDo>"
		postData = postData + "</soap:Body>"
		postData = postData + "</soap:Envelope>"	
		
		Call logInfo(postData)
		Call logInfo(URLEncode(postData))
		
		oXMLHttp.Open "Post", postURL, False  	
		oXMLHttp.setRequestHeader "Content-Type", "text/xml; charset=utf-8"
		oXMLHttp.setRequestHeader "Content-length", Len(URLEncode(postData)) 
		oXMLHttp.setRequestHeader "Accept-Language","zh-CN" 
		oXMLHttp.setRequestHeader  "SOAPAction","http://webservice.iipa/SaveToDo"
		oXMLHttp.setRequestHeader "Host",host
		oXMLHttp.Send URLEncode(postData)
 
		responseText = oXMLHttp.responseText
		
		Call logInfo("返回状态：" & oXMLHttp.Status)
		Call logInfo("返回字段：" + responseText)
		
		MsgBox responseText, 0 + 64,"提示"
		
		If oXMLHttp.Status = 200 Then        
			sXML = oXMLHttp.responseText 
			resStr = StrLeft(sXML,"</SaveToDoResult>")
 
			Set oXML = CreateObject("Microsoft.XMLDOM")
			oXML.async = False 
		
			oXML.load(oXMLHttp.responseXML)
		
			
			
			Dim values As Variant
			
			'Set objNodes = oXML.selectNodes("//SaveToDoResult")	
			Set objNodes = oXML.selectNodes("//string")
			
			Forall objNode In objNodes
				MsgBox objNode.Text 
				Print objNode.Text
			End forall
			
'			MsgBox oXML.getElementsByTagName("SaveToDoResult").Length
'			
'			ForAll value In oXML.documentElement.childNodes
'				Print value.nodename
'				Print value.text
'			End ForAll
		
		Else
			MsgBox "服务器返回异常！返回代码：" & oXMLHttp.Status, 0 + 16,"提示"
		End If 
		Set oXMLHttp = Nothing		
		
		
	Else
		Call logInfo("参数不对！" &" n = " & n &"FilterItem = " &UBound(FilterItem) & " OwnerSSICID = " & UBound(OwnerSSICID) &" AppID =  " & UBound(AppID)&" ToDoID = " & UBound(ToDoID) &" Title = " & UBound(Title) &" Url = " & UBound(Url) & " ExpireDate = " & UBound(ExpireDate)&" CreateTime = " & UBound(CreateTime) & " Action = " & UBound(Action)&" UpdateTime = " & UBound(UpdateTime)&" Remark1 = " &UBound(Remark1)&" Remark2 = " & UBound(Remark2)&" Remark3 = " & UBound(Remark3))
	End If
	
 
ErrExit:
	Exit Function
ErrSub:
	MsgBox "服务器异常！"& Err & " " & Error  , 0 + 16 , "提示" 
	Resume ErrExit
End Function
 
原文链接：https://blog.csdn.net/kangkanglou/article/details/38980691