【Vegas原创】A系统(aspx)向B系统(asp)交互（XmLHttp）

A系统：

Imports System.Xml

Partial Class _Default

Inherits System.Web.UI.Page

Protected Sub Page_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load

Dim strXML As String

Dim URL As String

Dim strRtn As String

strXML = "<?xml version='1.0' encoding='utf-8' ?><ROOT>"

strXML = strXML & "<FORM_KIND>***</FORM_KIND>"

strXML = strXML & "<IS_UPDATE>N</IS_UPDATE>"

strXML = strXML & "<FORM_NO>0</FORM_NO>" 'IS_UPDATE等于Y时为表单号码

strXML = strXML & "<FORM_FILLER>0606806</FORM_FILLER>" '填表人工号

strXML = strXML & "<EMP_NO>0606806</EMP_NO>" '申请人工号

strXML = strXML & "<FIELD_COUNT>7</FIELD_COUNT>" '分隔的字段数

strXML = strXML & "<FIELDS>"

strXML = strXML & "TRAIN_NAME*+*TRAIN_NO*+*TIME*+*HOURS*+*PROCESS_UNIT*+*NEED_RETURN*+*APP_NAME"

strXML = strXML & "</FIELDS>"

strXML = strXML & "<ROWS>"

strXML = strXML & "<ROW>"

strXML = strXML & "<VALUE>"

strXML = strXML & "test*+*123*+*11:00*+*12*+*SC00*+*Y*+*Vegas"

strXML = strXML & "</VALUE>"

strXML = strXML & "</ROW>"

strXML = strXML & "</ROWS>"

strXML = strXML & "</ROOT>"

Dim xmlhttp As New MSXML.XMLHTTPRequest()

URL = "http://***/forms/VegasTest.asp?xmlText=" & strXML

xmlhttp.open("POST", URL, False)

xmlhttp.send()

Dim xmlDom As New System.Xml.XmlDocument

xmlDom.LoadXml(xmlhttp.responseText)

Dim Form_Result As String

Dim Form_Kind As String

Dim Form_No As String

Dim Err_Desc As String

Form_Result = xmlDom.SelectSingleNode("/ROOT/FORM_RESULT").InnerXml

Form_Kind = xmlDom.SelectSingleNode("/ROOT/FORM_KIND").InnerXml

Form_No = xmlDom.SelectSingleNode("/ROOT/FORM_NO").InnerXml

Err_Desc = xmlDom.SelectSingleNode("/ROOT/FORM_DESC").InnerXml

strRtn = ""

If Form_Result = "Y" Then '成功

'…

strRtn = ""

ElseIf Form_Result = "N" Then '失败

'…

strRtn = "Failure"

ElseIf Form_Result = "ERROR" Then '失败

'…

strRtn = Err_Desc

End If

lblMsg.text = strRtn

End Sub

End Class

B系统：

<%@CODEPAGE=936 Language=VBScript%>

<%Response.Charset="gb2312"%>

<%Response.Buffer=true %>

On Error Resume Next

'**接收客户端XML包的数据格式

'**FIELDS和VALUE中的字段以 *+* 来分隔，且分隔数量必须相同

dim xmlDom

set xmlDom=createobject("MSXML2.DOMDocument")

xmlDom.async=False

flag = xmlDom.loadxml(request.QueryString("xmlText"))

if flag then

dim cnn,RsFindEmp_ID

Set cnn=Server.CreateObject("ADODB.Connection")

cnn.Open Session("ConnectionString")

'myWriteLog Form_Kind,"1. Receive: " & xmlDom.xml

dim Form_No, Form_kind, strFlag

dim Form_Filler, Emp_No

dim FieldCount

dim arrC1, arrC2

dim strFields,strValue

Form_No = trim(xmlDom.selectSingleNode("/ROOT/FORM_NO").Text)

Form_kind = trim(xmlDom.selectSingleNode("/ROOT/FORM_KIND").Text)

Form_Filler = trim(xmlDom.selectSingleNode("/ROOT/FORM_FILLER").Text)

Emp_No = trim(xmlDom.selectSingleNode("/ROOT/EMP_NO").Text)

FieldCount = trim(xmlDom.selectSingleNode("/ROOT/FIELD_COUNT").Text)

strFlag = trim(xmlDom.selectSingleNode("/ROOT/IS_UPDATE").Text)

myWriteLog Form_Kind,"1. Receive: " & xmlDom.xml

FieldCount = FieldCount * 1

strFields = xmlDom.selectSingleNode("/ROOT/FIELDS").Text

arrC1=Split(strFields,"* *")

dim SqlFindEmp_ID,strEmpId

SqlFindEmp_ID="select ***."

set RsFindEmp_ID=cnn.Execute(SqlFindEmp_ID)

if not RsFindEmp_ID.eof then

strEmpId=RsFindEmp_ID("Emp_ID")

RsFindEmp_ID.Close()

else

ReturnXML Form_Kind,Form_No,"ERROR","NOEMP_3__" & SqlFindEmp_ID

end if

select case strFlag

case "N" 'New Form

if Form_No<=0 then

Form_No=CreateForm (Form_Kind,strEmpId) '调用flowER组件来生成表单编号(FORM_NO)

end if

case "Y" 'Update Form

Form_No = trim(xmlDom.selectSingleNode("/ROOT/FORM_NO").Text)

end select

'response.write strEmpId & "-" & Form_Kind & "-" & Form_No

'response.end

if CLng(Form_No) <= 0 then

Connection.Execute "exec sp_Facade_DeleteForm Form_Kind," & Form_No

ReturnXML Form_Kind,"3","ERROR","FORM_NO"

end if

dim strsql, intPos

dim nodeList

dim xmlNod

set nodeList = xmlDom.selectNodes("/ROOT/ROWS/ROW")

For Each xmlNod In nodeList

strValue = xmlNod.SelectSingleNode("VALUE").Text

arrC2=Split(strValue,"* *")

'*******************************************************************************************************************8

select case Form_Kind

case "***"

intPos=GetIndex(arrC1, FieldCount, "TRAIN_NAME")

strTrainName=arrC2(intPos)

intPos=GetIndex(arrC1, FieldCount, "TRAIN_NO")

strTrainNo=arrC2(intPos)

intPos=GetIndex(arrC1, FieldCount, "TIME")

strTime=arrC2(intPos)

intPos=GetIndex(arrC1, FieldCount, "HOURS")

strHours=arrC2(intPos)

intPos=GetIndex(arrC1, FieldCount, "PROCESS_UNIT")

strProcessUnit=arrC2(intPos)

intPos=GetIndex(arrC1, FieldCount, "NEED_RETURN")

strNeedReturn=arrC2(intPos)

intPos=GetIndex(arrC1, FieldCount, "APP_NAME")

strAppName=arrC2(intPos)

'----------更新或插入表单数据

strsql="***."

'end modify

set myt=cnn.Execute(strsql)

if not myt.eof then

''********************************************************回传参数

ReturnXML Form_Kind,Form_No,"Y","T024_ALREADY EXIST_" & myt("FORM_NO")

strsql="sp_Facade_DeleteForm '***'," & Form_No

cnn.Execute strsql

else

strsql="procedure *** '" & Form_Filler & "','" & Form_Kind & "'," & Form_No & ",'" & Emp_No & "'"

strsql=strsql & ",'" & strTrainName & "','" & strTrainNo & "','" & strTime & "','"

strsql=strsql & strHours & "','" & strProcessUnit & "','" & strNeedReturn & "','" & strAppName & "'"

cnn.Execute strsql

end if

end select

myWriteLog Form_Kind,"2. Execute: " & strsql

next 'Each in nodeList

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Form_No=Form_No & ""

SendFormResult=SendForm(Form_Kind, Form_No & "", strEmpId, "1") '调用flowER组件来生成或更新表单

ActiveFormResult=ActiveForm(Form_Kind, Form_No & "")

if LCase(SendFormResult)="true" then

strResult="Y"

else

strResult="N"

end if

'*************************************************************

'**Return the result to client

ReturnXML Form_Kind,Form_No,strResult,err.description

else

'response.Write 11

'response.End

ReturnXML "0","0","ERROR","RECEIVE: " & xmlDom.parseError.reason

'response.write xmlDom.parseError.reason

end if

'**********************************************************************

'**Get the index of array

function GetIndex(arrExpression, arrCount, SearchString)

dim intPos, i

arrCount=arrCount*1

if UCase(isArray(arrExpression)) = "FALSE" or arrCount<=0 then

intPos=0

else

for i=0 to arrCount-1

if SearchString=arrExpression(i) then

intPos=i

end if

GetIndex=intPos

end function

'**********************************************************************

'**Return the processed result to client

sub ReturnXML(Form_Kind, Form_No, Result, Desc)

on error resume next

strxml="<?xml version='1.0' encoding='utf-8' ?><ROOT>"

strxml=strxml & "<FORM_KIND>" & Form_Kind & "</FORM_KIND>"

strxml=strxml & "<FORM_NO>" & Form_No & "</FORM_NO>"

strxml=strxml & "<FORM_RESULT>" & Result & "</FORM_RESULT>"

strxml=strxml & "<FORM_DESC>" & Desc & "</FORM_DESC>"

strxml=strxml & "</ROOT>"

myWriteLog Form_Kind,"3. Return: FORM_KIND=" & Form_Kind & " -- FORM_NO=" & Form_No & " -- FORM_RESULT=" & Result & " -- ERR_DESC=" & Desc

response.write strxml

if Result<>"Y" then '发生错误时删除该表单 Anson,04/12/2004

Connection.Execute "exec sp_Facade_DeleteForm '" & trim(Form_Kind) & "'," & Form_No

myWriteLog Form_Kind,"3. Return--DELETE: FORM_KIND=" & Form_Kind & " -- FORM_NO=" & Form_No & " -- FORM_RESULT=" & Result & " -- ERR_DESC = DELETE"

end if

response.end

end sub

'**********************************************************************

'**

sub myWriteLog(FORM_KIND,strMsg)

on error resume next

dim strLogFileName

'strLogFileName = "Receive_FormData_" & FORM_KIND & ".Log" 'Log文件名

strLogFileName = "LOG\COMMON\" & FORM_KIND & "_" & Year(date) & "-" & Month(date) & "-" & Day(date) & ".Log" 'Log文件名

WriteLog strLogFileName,strMsg,true

end sub