Option Explicit Private RCommands As Recordset Private RCustomers As Recordset Private RCust As Recordset Private sCustListCommand As String Private Const dataURL = "http://localhost/XHTTPRequest/getData.asp" Private arrCustomerIDs() As String Private Enum ActionEnum VIEW_HISTORY = 0 VIEW_RECENT_PRODUCT = 1 End Enum
Private Sub dgCustomers_Click() Dim CustomerID As String CustomerID = RCustomers("CustomerID").Value If CustomerID <> "" Then If optAction(VIEW_HISTORY).Value Then Call getCustomerDetail(CustomerID) Else Call getRecentProduct(CustomerID) End If End If End Sub
Private Sub Form_Load() Call initialize Call getCustomerList End Sub
Sub initialize() ' 从数据库返回命令名和相应的值
Dim sXML As String Dim vRet As Variant Dim F As Field sXML = "<?xml version=""1.0""?>" sXML = sXML & "<command><commandtext>Initialize</commandtext>" sXML = sXML & "<returnsdata>True</returnsdata>" sXML = sXML & "</command>" Set RCommands = getRecordset(sXML) Do While Not RCommands.EOF For Each F In RCommands.Fields Debug.Print F.Name & "=" & F.Value Next RCommands.MoveNext Loop End Sub
Function getCommandXML(command_name As String) As String RCommands.MoveFirst RCommands.Find "command_name='" & command_name & "'", , adSearchForward, 1 If RCommands.EOF Then MsgBox "Cannot find any command associated with the name '" & command_name & "'." Exit Function Else getCommandXML = RCommands("command_xml") End If End Function
Sub getRecentProduct(CustomerID As String) Dim sXML As String Dim xml As DOMDocument Dim N As IXMLDOMNode Dim productName As String sXML = getCommandXML("RecentPurchaseByCustomerID") Set xml = New DOMDocument xml.loadXML sXML Set N = xml.selectSingleNode("command/param[name='CustomerID']/value") N.Text = CustomerID Set xml = executeSPWithReturn(xml.xml) productName = xml.selectSingleNode("values/ProductName").Text ' 显示text域 txtResult.Text = "" Me.txtResult.Visible = True dgResult.Visible = False ' 显示product名 txtResult.Text = "最近的产品是: " & productName End Sub
Sub getCustomerList() Dim sXML As String Dim i As Integer Dim s As String sXML = getCommandXML("getCustomerList") Set RCustomers = getRecordset(sXML) Set dgCustomers.DataSource = RCustomers End Sub
Sub getCustomerDetail(CustomerID As String) ' 找出列表中相关联的ID号 Dim sXML As String Dim R As Recordset Dim F As Field Dim s As String Dim N As IXMLDOMNode Dim xml As DOMDocument sXML = getCommandXML("CustOrderHist") Set xml = New DOMDocument xml.loadXML sXML Set N = xml.selectSingleNode("command/param[name='CustomerID']/value") N.Text = CustomerID Set R = getRecordset(xml.xml) ' 隐藏 text , 因为它是一个记录集 txtResult.Visible = False
dgResult.Visible = True Set dgResult.DataSource = R End Sub
Function getRecordset(sXML As String) As Recordset Dim R As Recordset Dim xml As DOMDocument Set xml = getData(sXML) Debug.Print TypeName(xml) On Error Resume Next Set R = New Recordset R.Open xml If Err.Number <> 0 Then MsgBox Err.Description Exit Function Else Set getRecordset = R End If End Function
Function executeSPWithReturn(sXML As String) As DOMDocument Dim d As New Dictionary Dim xml As DOMDocument Dim nodes As IXMLDOMNodeList Dim N As IXMLDOMNode Set xml = getData(sXML) If xml.documentElement.nodeName = "values" Then Set executeSPWithReturn = xml Else '发生错误
Set N = xml.selectSingleNode("response/data") If Not N Is Nothing Then MsgBox N.Text Exit Function Else MsgBox xml.xml Exit Function End If End If End Function
Function getData(sXML As String) As DOMDocument Dim xhttp As New xmlhttp30 xhttp.Open "POST", dataURL, False xhttp.send sXML Debug.Print xhttp.responseText Set getData = xhttp.responseXML End Function
Private Sub optAction_Click(Index As Integer) Call dgCustomers_Click End Sub
代码二、getData.asp
<%@ Language=VBScript %> <% option explicit %> <% Sub responseError(sDescription) Response.Write "<response><data>Error: " & sDescription & "</data></response>" Response.end End Sub
Response.ContentType="text/xml" dim xml dim commandText dim returnsData dim returnsValues dim recordsAffected dim param dim paramName dim paramType dim paramDirection dim paramSize dim paramValue dim N dim nodeName dim nodes dim conn dim sXML dim R dim cm
' 创建DOMDocument对象 Set xml = Server.CreateObject("msxml2.DOMDocument") xml.async = False
' 装载POST数据 xml.Load Request If xml.parseError.errorCode <> 0 Then Call responseError("不能装载 XML信息。 描述: " & xml.parseError.reason & "<br>行数: " & xml.parseError.Line) End If
' 客户端必须发送一个commandText元素 Set N = xml.selectSingleNode("command/commandtext") If N Is Nothing Then Call responseError("Missing <commandText> parameter.") Else commandText = N.Text End If
' 客户端必须发送一个returnsdata或者returnsvalue元素 set N = xml.selectSingleNode("command/returnsdata") if N is nothing then set N = xml.selectSingleNode("command/returnsvalues") if N is nothing then call responseError("Missing <returnsdata> or <returnsValues> parameter.") else returnsValues = (lcase(N.Text)="true") end if else returnsData=(lcase(N.Text)="true") end if
set cm = server.CreateObject("ADODB.Command") cm.CommandText = commandText if instr(1, commandText, " ", vbBinaryCompare) > 0 then cm.CommandType=adCmdText else cm.CommandType = adCmdStoredProc end if
' 创建参数 set nodes = xml.selectNodes("command/param") if nodes is nothing then ' 如果没有参数 elseif nodes.length = 0 then ' 如果没有参数 else for each param in nodes ' Response.Write server.HTMLEncode(param.xml) & "<br>" on error resume next paramName = param.selectSingleNode("name").text if err.number <> 0 then call responseError("创建参数: 不能发现名称标签。") end if paramType = param.selectSingleNode("type").text paramDirection = param.selectSingleNode("direction").text paramSize = param.selectSingleNode("size").text paramValue = param.selectSingleNode("value").text if err.number <> 0 then call responseError("参数名为 '" & paramName & "'的参数缺少必要的域") end if cm.Parameters.Append cm.CreateParameter(paramName,paramType,paramDirection,paramSize,paramValue) if err.number <> 0 then call responseError("不能创建或添加名为 '" & paramName & "的参数.' " & err.description) Response.end end if next on error goto 0 end if
'打开连结 set conn = Server.CreateObject("ADODB.Connection") conn.Mode=adModeReadWrite conn.open application("ConnectionString") if err.number <> 0 then call responseError("连结出错: " & Err.Description) Response.end end if
' 连结Command对象 set cm.ActiveConnection = conn
' 执行命令 if returnsData then ' 用命令打开一个Recordset set R = server.CreateObject("ADODB.Recordset") R.CursorLocation = adUseClient R.Open cm,,adOpenStatic,adLockReadOnly else cm.Execute recordsAffected, ,adExecuteNoRecords end if if err.number <> 0 then call responseError("执行命令错误 '" & Commandtext & "': " & Err.Description) Response.end end if
if returnsData then R.Save Response, adPersistXML if err.number <> 0 then call responseError("数据集发生存储错误,在命令'" & CommandText & "': " & Err.Description) Response.end end if elseif returnsValues then sXML = "<?xml version=""1.0"" encoding=""gb2312""?>" & vbcrlf & "<values>" set nodes = xml.selectNodes("command/param[direction='2']") for each N in nodes nodeName = N.selectSingleNode("name").text sXML = sXML & "<" & nodename & ">" & cm.Parameters(nodename).Value & "" & "</" & nodename & ">" next sXML = sXML & "</values>" Response.Write sXML end if
set cm = nothing conn.Close set R = nothing set conn = nothing Response.end %>