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("http://SaveToDoResult")	
			Set objNodes = oXML.selectNodes("http://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