سلام
چيزي كه من متوجه شدم در مرحله بايد از وب سرويس توكن دريافت بشه كه اعتبار يكروزه داره . براي اينكار بايد از وب سرويس getTOKEN استفاده بشه كه سه تا پارامتر كد موسسه نام كاربر و پسورد رو دريافت و كدي ارسال مي كنه.
براي شروع من كدهاي جناب mazoolagh كمي تغيير دادم ولي تست نشده هست و احتمالا خطا خواهد داشت. لطفا تست بكنيد و نتيجه رو اعلام كنيد.
Option Compare Database
Option Explicit
Const WSURL As String = "http://test.ihio.gov.ir/hdkcore/services/authenticationservice?wsdl"
'--------------------------
Public Type Request_Response
TOKEN_ID As String
ERROR_MESSAGE As String
End Type
'--------------------------
Public Function getTOKEN( _
ByVal pUserInstKey As String, _
ByVal pUserName As String, _
ByVal pPassword As String) As Request_Response
On Error GoTo ERR_HNDLR
Dim RR As Request_Response
RR.TOKEN_ID = ""
RR.ERROR_MESSAGE = ""
Dim XM As String
XM = "<?xml version=""1.0"" encoding=""utf-8""?>"
XM = XM + "<soap12:Envelope xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xmlns:xsd=""http://www.w3.org/2001/XMLSchema"" xmlns:soap12=""http://www.w3.org/2003/05/soap-envelope"">"
XM = XM + "<soap12:Body>"
XM = XM + "<getTOKEN xmlns=""http://tempuri.org/"">"
XM = XM + "<pUserInstKey>" + pUserInstKey + "</pUserInstKey>"
XM = XM + "<pUserName>" + pUserName + "</pUserName>"
XM = XM + "<pPassword>" + pPassword + "</pPassword>"
XM = XM + "</getTOKEN>"
XM = XM + "</soap12:Body>"
XM = XM + "</soap12:Envelope>"
Dim XML_HTTP As New MSXML2.XMLHTTP60
XML_HTTP.Open "POST", WSURL, False
XML_HTTP.setRequestHeader "HOST", "http://test.ihio.gov.ir/hdkcore/api/services/"
XML_HTTP.setRequestHeader "CONTENT-TYPE", "application/soap+xml; charset=utf-8"
XML_HTTP.setRequestHeader "SOAPACTION", "http://tempuri.org/Save_Request"
XML_HTTP.send XM
Dim XML_DOC As New MSXML2.DOMDocument60
Dim XNL As MSXML2.IXMLDOMNodeList
Dim I As Integer
If XML_HTTP.Status = 200 Then
XML_DOC.loadXML XML_HTTP.responseText
Set XNL = XML_DOC.getElementsByTagName("*")
For I = 0 To XNL.length - 1
Select Case XNL(I).nodeName
Case "TOKEN_Id"
RR.TOKEN_ID = XNL(I).Text
Case "ErrorMessage"
RR.ERROR_MESSAGE = XNL(I).Text
End Select
Next
Else
RR.ERROR_MESSAGE = CStr(XML_HTTP.Status) + XML_HTTP.StatusText
End If
getTOKEN = RR
Set XML_HTTP = Nothing
Exit Function
ERR_HNDLR:
RR.ERROR_MESSAGE = "ERROR " + CStr(Err.number) + vbCrLf + Err.Description
getTOKEN = RR
End Function