使用Soap Toolkit及Soap协议访问WebService
本文使用的soap toolkit 3.0直接上VB代码：
Sub SoapMethod()
On Error GoTo errhandler
'方法1：使用soap toolkit,此方法需要安装soap toolkit3.0
Dim soapclient As Object
Set soapclient = CreateObject("MSSOAP.SoapClient30")
soapclient .ClientProperty("ServerHTTPRequest") = True '运行 ASP 页中的 MSXML HTTP 堆栈要求使用 ServerHTTPRequest 选项
soapclient.mssoapinit "http://localhost:8087/?wsdl" '服务端地址
ss$ = soapclient.HelloWorld '直接调用服务端方法
i% = soapclient.Sum(1, 2)
'方法2：使用soap协议，需要发送报文，返回的也是xml报文，需要自己解析
Dim xmldoc As Object
'创建xml格式对象，用于加载xml格式字符串（xml请求和应答），加载进去之后遍历其中的各个节点
Set xmldoc = CreateObject("MSXML2.DOMDocument")
Dim httprequest As Object
Set httprequest = CreateObject("MSXML2.ServerXMLHTTP") '定义http对象，向服务器发送Post消息
'组装xml请求报文
Dim strtest As String
strtest = " "
strtest = strtest + " "
strtest = strtest + " "
'strtest = strtest + " 12 " '带参数a、b，值分别为1、2的sum方法
strtest = strtest + " "
strtest = strtest + " "
xmldoc.LoadXML strtest '加载xml文档用于解析
httprequest.Open "POST", "http://localhost:8087/?wsdl", False
httprequest.setRequestHeader "Content-Type", "text/xml"
httprequest.send strtest
While httprequest.readyState <> 4
Wend
Dim httpresponse As String
httpresponse = httprequest.responseText '获取应答报文
'MsgBox httpresponse
xmldoc.LoadXML httpresponse '加载xml文档用于解析
Dim xmlRootElement As Object
Set xmlRootElement = xmldoc.DocumentElement
MsgBox xmlRootElement.Text
Exit Sub
errhandler:
MsgBox "err"
End Sub
其中可能会遇到一些问题：
1 使用MSSoap.SoapClient对象
该对象对低版本的WSDL能够支持，但遇到高版本的WSDL就会出现以下的错误：
访问WebService错误WSDLReader:Analyzing the WSDL file failed HRESULT=0x80004005
- WSDLReader:Initialization of service failed HRESULT=0x80004005
- WSDLService:Initialization of the port for service JaxRpcOutAccessService failed HRESULT=0x80004005
- WSDLPort:Analyzing the binding information for port VioOutAccess failed HRESULT=0x80004005
- WSDLPort:An operation for port VioOutAccess could not be initialized HRESULT=0x80004005
- WSDLOperation:Initializing of the input message failed for operation queryVioSurveil HRESULT=0x80004005
- WSDLOperation:Initialization of a SoapMapper for operation queryVioSurveil failed HRESULT=0x80004005
- SoapMapper:The SoapMapper for element string could not be created HRESULT=0x80004005
- SoapMapper:The schema definition with a targetnamespace of http://schemas.xmlsoap.org/soap/encoding/ for SoapMapper string could not be found HRESULT=0x80004005
这个问题一般是因为WSDL版本太高soapclient对象支持不好造成的，解决办法就是换用MSSOAPLib30.SoapClient30对象。
2 使用MSSOAPLib30.SoapClient30对象
该版本支持的WSDL版本较MSSOAPLib.SoapClient略高，但最新的版本也是不支持的。该版本常见的错误如下：
访问WebService错误SoapMapper:The schema definition with a targetnamespace of http://schemas.xmlsoap.org/soap/encoding/ for SoapMapper string could not be found HRESULT=0x80004005: 未指定的错误
- SoapMapper:The SoapMapper for element string could not be created HRESULT=0x80004005: 未指定的错误
- WSDLOperation:Initialization of a SoapMapper for operation queryVioSurveil failed HRESULT=0x80004005: 未指定的错误
- WSDLOperation:Initializing of the input message failed for operation queryVioSurveil HRESULT=0x80004005: 未指定的错误
- WSDLPort:An operation for port VioOutAccess could not be initialized HRESULT=0x80004005: 未指定的错误
- WSDLPort:Analyzing the binding information for port VioOutAccess failed HRESULT=0x80004005: 未指定的错误
- WSDLService:Initialization of the port for service JaxRpcOutAccessService failed HRESULT=0x80004005: 未指定的错误
- WSDLReader:Analyzing the WSDL file failed HRESULT=0x80004005: 未指定的错误
- Client:One of the parameters supplied is invalid. HRESULT=0x80070057: 参数不正确。
2.1 这个问题是因为，WSDL少type（WSDL描述可以看看这里），就是
如果WebService是自己发布的话则可以修改相应的部分使WSDL能够被MSSOAPLib30.SoapClient30对象所支持，否则就只能在VB6.0和高版本的WSDL之间建立一个桥梁。比如用.net访问WSDL，然后VB6.0再去调用.NET。
2.2 上一个问题还有一个可能性就是WSDL命名空间（暂且这么叫）的问题。
例如：
比较关键的两个地方是xmlns:xsd="http://www.w3.org/2001/XMLSchema"和xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/"对应着
里面的type=“soapenc:string”。现在这样的配置一般VB6.0不能正确的解析，如果要能正确额解析就要把xmlns:soapenc=“http://schemas.xmlsoap.org/soap/encoding/” 改为xmlns:soapenc=“http://www.w3.org/2001/XMLSchema” ；或是把type="soapenc:string"改为type=“xsd:string”。这样VB6.0就能正确的访问了。
另外参考文章：
Microsoft SOAP Toolkit v2_0 常见问题解答（SOAP 技术文章）
另一段VB实例代码（不能直接使用，可参考）：
Private constr_new As String
'Const constr_new = "driver=SQL server;server=CCT02030\CAF2ETSDB;uid=cimp_dbo;pwd=cimp_dbo;database=ATE_DB"
Const adOpenKeyset = 1
Const adLockOptimistic = 3
Private gsLogFile As String
Private gsScriptName As String
Const WSDL_URL = "http://19.250.1.47:9268"
Const WSDL_URL_Return = "http://19.250.1.47:9269"
'******************************************************************************
' Sub: ComLogMsg()
'
' Notes: Logs a message to a log file. The current date "_mmm-yyyy.txt"
' is added to the end of the given file name.
'******************************************************************************
Private Sub ComLogMsg(ByVal vsLogFile As String,ByVal strScriptName As String,ByVal errCode As Long,ByVal errLine As Long,ByVal vsMsg As String)
Dim iFileNum As Integer
Dim sFileName As String
On Error GoTo Error_Exit
iFileNum = FreeFile()
sFileName = vsLogFile & "_" & Format(Now(), "yyyy-mm-dd") & ".txt"
Open sFileName For Append Access Write Lock Write As iFileNum
Write iFileNum, Format(Now(), "yyyy-mm-dd hh:mm:ss"), vsMsg & " err=" & errCode & " erl=" & errLine
Close iFileNum
'Exit Sub
Error_Exit:
'Trace Time$ & " " & strScriptName & " vsMsg=" & vsMsg
LogStatus CIM_FAILURE, strScriptName,vsMsg,errCode,errLine
End Sub
'When the SQL statement fails, save it as a error file and continue execution next time
Sub SaveFile(strArray() As String,strFilePath As String,strBackupPath As String)
Dim strErrorCount As String
Dim errocount As Integer
Dim iLBound As Integer
Dim iUBound As Integer
Dim iIndex As Integer
On Error GoTo ErrorHandler
iLBound= LBound(strArray)
iUBound = UBound(strArray)
iIndex = 0
errocount = 0
strErrorCount = ReadIni$("Errcount","count", strFilePath)
If strErrorCount = "" Then strErrorCount = "0"
errocount = CINT(strErrorCount)
errocount = errocount + 1
If errocount > 10 Then
CleanFile strArray,strFilePath,strBackupPath
Else
For i=iLBound To iUBound
If(trim(strArray(i)) <> "") Then
iIndex = iIndex + 1
WriteIni "strSql" & iIndex,"str",strArray(i),strFilePath
End If
Next i
WriteIni "strSqlCount","count",iIndex,strFilePath
WriteIni "Errcount","count",errocount,strFilePath
End If
Exit Sub
ErrorHandler:
Call ComLogMsg(gsLogFile,gsScriptName,err,erl,error$)
End Sub
'backing up the error file
Sub CleanFile(strArray() As String,strFilePath As String,strBackupPath As String)
Dim timestring As string
timestring = format(now,"YYYY-MM-DD-hh-mm-ss")
SaveFile strArray,strBackupPath & timestring & ".ini",strFilePath
WriteIni "Errcount","count",0,strFilePath
End Sub
'Check if the error file has failed execution records
Function HasCacheStrSql(strFilePath As String) As Boolean
Dim strErrorCount As String
Dim strCount As Integer
On Error GoTo ErrorHandler
strCount = 0
strErrorCount = ReadIni$("Errcount","count", strFilePath)
If strErrorCount = "" Then strErrorCount = "0"
strCount = CINT(strErrorCount)
If ( strCount > 0 ) Then
HasCacheStrSql = TRUE
Else
HasCacheStrSql = FALSE
End If
Exit Function
ErrorHandler:
HasCacheStrSql = FALSE
Call ComLogMsg(gsLogFile,gsScriptName,err,erl,error$)
End Function
'**************************************************************************
'**** Name ExecuteSqlArray **********************************
'**** Function Save data to database*************
'**** Parameter: String @strArray() SQL statements********************
'**** Return: String "OK" means **********************
'********* SQL statement executed successfully
'**************************************************************************
Function ExecuteSqlArray( strArray() As String,strFilePath As String,strBackupPath As String,connectString As String) As String
Dim iLBound As Integer
Dim iUBound As Integer
iLBound= LBound(strArray)
iUBound = UBound(strArray)
On Error GoTo ErrorHandler
Set conODBC = CreateObject("ADODB.Connection")
conODBC.Open connectString
conODBC.BeginTrans
For i=iLBound To iUBound
If(trim(strArray(i)) <> "") Then
Set ExecResult = conODBC.Execute(strArray(i))
Set ExecResult = Nothing
End If
Next i
conODBC.CommitTrans
ExecuteSqlArray = "OK"
conODBC.Close
WriteIni "Errcount","count",0,strFilePath
Exit Function
ErrorHandler:
conODBC.RollbackTrans
SaveFile strArray,strFilePath,strBackupPath
ExecuteSqlArray = "ErrNumber " _
& err.number & "ErrSource " & err.Source _
& " ErrDescription " & err.Description
Call ComLogMsg(gsLogFile,gsScriptName,err,erl,error$)
If conODBC.State = 1 Then conODBC.Close
End Function
'****Analyze NGAVSInfo******
Function AnalyzeNgvsInfo_New(strNgsInfo As String) As String
Dim strSql As String
Dim strSqlResult As String
Dim strVIN As String
Dim strSequenceTime As String
Dim strCartypeid As String
Dim strCatCode As String
Dim strSN As String
Set conODBC = CreateObject("ADODB.Connection")
Set adoRS = CreateObject("ADODB.Recordset")
On Error GoTo ErrorHandler
conODBC.Open constr_new
If (left( strNgsInfo,1) <> "$" ) Or _
(right(strNgsInfo,1) <> "@" ) Then
strSqlResult = "insert into [ATE_NGVS_DEBUG]([ngvsinfo],[updatetime])" _
& " values('Analyze Failed:" & strNgsInfo & "',getdate())"
Call ComLogMsg(gsLogFile,gsScriptName,err,erl,error$ & "Analyze Failed,Get More Information from SQL DataTable ATE_NGVS_DEBUG")
Else
strVIN = Mid(strNgsInfo,4,17)
strSequenceTime = Mid(strNgsInfo,117,16)
strCatCode = Mid(strNgsInfo,21,5)
strSN = Mid(strNgsInfo,161,4)
strSql = "SELECT [CarTypeid] FROM [dbo].[ATE_CATCODE_TYPE] where [CatCode] = '" & strCatCode & "'"
adoRS.Open strSql, conODBC, adOpenKeyset, adLockOptimistic
If adoRS.EOF = False Then
strCartypeid = adoRS.Fields(0)
strSqlResult = "insert into ATE_CAR_INFOR(VIN,CatCode,car_type_id," _
& "VIN_Sequence,Entry_On,printSerNum,comments,ngvsinfo) values('" & strVIN & "','" & strCatCode & "','"_
& strCartypeid & "','" & strSequenceTime & "',getdate(),'" & strSN & "','','" & strNgsInfo & "')"
Else
strSqlResult = "insert into [ATE_NGVS_DEBUG]([ngvsinfo],[updatetime])" _
& " values('Can not find CarType:" & strVIN & "',getdate())"
Call ComLogMsg(gsLogFile,gsScriptName,err,erl,error$ & "Can not find CarType,Get More Information from SQL DataTable ATE_NGVS_DEBUG")
End If
adoRS.Close
conODBC.Close
End If
AnalyzeNgvsInfo_New = strSqlResult
Exit Function
ErrorHandler:
AnalyzeNgvsInfo_New = "insert into [ATE_NGVS_DEBUG]([ngvsinfo],[updatetime])" _
& " values('" & error$ & "',getdate())"
Call ComLogMsg(gsLogFile,gsScriptName,err,erl,error$)
If adoRS.State = 1 Then adoRS.Close
If conODBC.State = 1 Then conODBC.Close
End Function
'将收到的数据中的文件名返回给datapower，此时datapower不会返回应答报文，不需要解析
Sub ReturnFileNameToDataPower(strFileName As String)
Dim xmldoc_return As Object
Dim httprequest_return As Object
On Error GoTo errhandler
'使用soap协议，需要发送报文，返回的也是xml报文，需要自己解析
'创建xml格式对象，用于加载xml格式字符串（xml请求和应答），加载进去之后遍历其中的各个节点
Set xmldoc_return = CreateObject("MSXML2.DOMDocument")
Set httprequest_return = CreateObject("MSXML2.ServerXMLHTTP") '定义http对象，向服务器发送Post消息
'组装xml请求报文
Dim strRequest_return As String
strRequest_return = " "
strRequest_return = strRequest_return + " "
'strRequest_return = strRequest_return + "xmlns:ns=""urn:datapower"" "
strRequest_return = strRequest_return + " "
'strRequest_return = strRequest_return + " 12 " '带参数a、b，值分别为1、2的sum方法
strRequest_return = strRequest_return + " " + strFileName + " "
strRequest_return = strRequest_return + " "
strRequest_return = strRequest_return + " "
'xmldoc_return.LoadXML strRequest_return '加载xml文档用于解析
httprequest_return.Open "POST", WSDL_URL_Return, False
httprequest_return.setRequestHeader "Content-Type", "text/xml"
httprequest_return.send strRequest_return
Dim count_return As Integer
count_return = 0
While httprequest_return.readyState <> 4
If count_return < 1 Then
sleep 3000
count_return = count_return + 1
Else
Set xmldoc_return = Nothing
Set httprequest_return = Nothing
Call ComLogMsg(gsLogFile,gsScriptName,err,erl,"获取应答数据超时")
Exit Sub
End If
Wend
'Dim httpresponse_return As String
'httpresponse_return = httprequest_return.responseText '获取应答报文
'MsgBox httpresponse_return
'xmldoc_return.LoadXML httpresponse_return '加载xml文档用于解析
'Dim xmlRootElement_return As Object
'Set xmlRootElement_return = xmldoc_return.DocumentElement
'MsgBox xmlRootElement_return.Text
'Call ComLogMsg(gsLogFile,gsScriptName,err,erl,xmlRootElement_return.Text)
Set xmldoc_return = Nothing
Set httprequest_return = Nothing
Exit Sub
errhandler:
Set xmldoc_return = Nothing
Set httprequest_return = Nothing
Call ComLogMsg(gsLogFile,gsScriptName,err,erl,error$)
End Sub
'发送报文，从datapower获取数据，返回的数据中包含文件名，及条码数据
Function GetDataFromDataPower() As String
Dim xmldoc As Object
Dim httprequest As Object
Dim xmlNode_msg As Object
Dim xmlNode_filename As Object
Dim sMsg As String
Dim sFileName As String
On Error GoTo errhandler
GetDataFromDataPower = ""
'方法1：使用soap toolkit,此方法需要安装soap toolkit3.0
'Dim soapclient As Object
'Set soapclient = CreateObject("MSSOAP.SoapClient30")
'soapclient.mssoapinit WSDL_URL '服务端地址 需要服务器有生成wsdl文件
'ss$ = soapclient.getmsg("ATEE") '直接调用服务端方法
'方法2：使用soap协议，需要发送报文，返回的也是xml报文，需要自己解析
'创建xml格式对象，用于加载xml格式字符串（xml请求和应答），加载进去之后遍历其中的各个节点
Set xmldoc = CreateObject("MSXML2.DOMDocument")
Set httprequest = CreateObject("MSXML2.ServerXMLHTTP") '定义http对象，向服务器发送Post消息
'组装xml请求报文
Dim strRequest As String
strRequest = " "
strRequest = strRequest + " "
'strRequest = strRequest + "xmlns:ns=""urn:datapower"" "
strRequest = strRequest + " "
'strRequest = strRequest + " 12 " '带参数a、b，值分别为1、2的sum方法
strRequest = strRequest + " ATEENew "
strRequest = strRequest + " "
strRequest = strRequest + " "
'xmldoc.LoadXML strRequest '加载xml文档用于解析
httprequest.Open "POST", WSDL_URL, False
httprequest.setRequestHeader "Content-Type", "text/xml"
httprequest.send strRequest
Dim count As Integer
count = 0
While httprequest.readyState <> 4
If count < 1 Then
sleep 3000
count = count + 1
Else
Set xmldoc = Nothing
Set httprequest = Nothing
Set xmlNode_msg = Nothing
Set xmlNode_filename = Nothing
Call ComLogMsg(gsLogFile,gsScriptName,err,erl,"获取应答数据超时")
Exit Function
End If
Wend
Dim httpresponse As String
httpresponse = httprequest.responseText '获取应答报文
'MsgBox httpresponse
'Call ComLogMsg(gsLogFile,gsScriptName,err,erl,httpresponse)
xmldoc.LoadXML httpresponse '加载xml文档用于解析
'Dim xmlRootElement As Object
'Set xmlRootElement = xmldoc.DocumentElement '获取根节点下所有数据
'MsgBox xmlRootElement.Text
Set xmlNode_msg = xmldoc.selectSingleNode("//msg") '获取根节点下msg部分的数据
sMsg = xmlNode_msg.Text
If sMsg<>"null" Then
GetDataFromDataPower = sMsg
Set xmlNode_filename = xmldoc.selectSingleNode("//filename") '获取根节点下filename部分的数据
sFileName = xmlNode_filename.Text
ReturnFileNameToDataPower sFileName
End If
Set xmldoc = Nothing
Set httprequest = Nothing
Set xmlNode_msg = Nothing
Set xmlNode_filename = Nothing
Exit Function
errhandler:
Set xmldoc = Nothing
Set httprequest = Nothing
Set xmlNode_msg = Nothing
Set xmlNode_filename = Nothing
Call ComLogMsg(gsLogFile,gsScriptName,err,erl,error$)
End Function
Sub Main()
Dim hasesql As Boolean
Dim strSqlRead() As String
Dim strSqlCount As String
Dim sqlCount As Integer
Dim strNgvsInfo As String
Dim strSqlList_New(1) As String
Dim strResult As String
On Error GoTo ErrorHandler
'If PointGet("COMMON_IS_GETTING_NGVS_INFO") = true Then Exit Sub
'PointSet "COMMON_IS_GETTING_NGVS_INFO",true
sqlCount = 0
Dim filepath_new As String
Dim backuppath_new As String
filepath_new = Environ("SITE_ROOT") & "NGVS_CaChe\NGVS_NEW.ini"
backuppath_new = Environ("SITE_ROOT") & "NGVS_CaChe\NGVS_NEW_"
gsScriptName = "GetVINFromNGAVS.bcl"
gsLogFile = Environ("SITE_ROOT") & "log\" & Mid(gsScriptName,1,Len(gsScriptName)-4)
constr_new = "driver=SQL server;" & PointGet("CONNECTION_STRING")
hasesql = HasCacheStrSql (filepath_new)
If hasesql = true Then
strSqlCount = ReadIni$("strSqlCount","count", filepath_new)
sqlCount = CINT(strSqlCount)
ReDim strSqlRead(sqlCount)
For i= 1 To sqlCount
strSqlRead(i-1) = ReadIni$("strSql" & i,"str", filepath_new)
Next i
'execute strsql
strResult = ExecuteSqlArray(strSqlRead,filepath_new,backuppath_new,constr_new)
'PointSet "COMMON_IS_GETTING_NGVS_INFO",false
Exit Sub
End If
strNgvsInfo = GetDataFromDataPower()
'strNgvsInfo = "$02LVSHCFDB1DE42027387BFZO 62BDUMMYL 5C511399 YABQE420273 X2P WCH 7 AA A B A O 167 P100HS902013110100:14:12 B 4485 @"
If strNgvsInfo <> "null" And strNgvsInfo <> "" Then
strSqlList_New(0) = "insert into ATE_NGVS_DEBUG([ngvsinfo],[updatetime]) " _
& "values('" & strNgvsInfo & "',getdate())"
strResult = ExecuteSqlArray(strSqlList_New,filepath_new,backuppath_new,constr_new)
strSqlList_New(0) = AnalyzeNgvsInfo_New(strNgvsInfo)
strResult = ExecuteSqlArray(strSqlList_New,filepath_new,backuppath_new,constr_new)
End If
'PointSet "COMMON_IS_GETTING_NGVS_INFO",false
Exit Sub
ErrorHandler:
'PointSet "COMMON_IS_GETTING_NGVS_INFO",false
Call ComLogMsg(gsLogFile,gsScriptName,err,erl,error$)
End Sub