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() ' 從數(shù)據(jù)庫(kù)返回命令名和相應(yīng)的值
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 = "最近的產(chǎn)品是: " & 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) ' 找出列表中相關(guān)聯(lián)的ID號(hào) 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 , 因?yàn)樗且粋€(gè)記錄集 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 '發(fā)生錯(cuò)誤
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
' 創(chuàng)建DOMDocument對(duì)象 Set xml = Server.CreateObject("msxml2.DOMDocument") xml.async = False
' 裝載POST數(shù)據(jù) xml.Load Request If xml.parseError.errorCode ＜＞ 0 Then Call responseError("不能裝載 XML信息。 描述: " & xml.parseError.reason & "＜br＞行數(shù): " & xml.parseError.Line) End If
' 客戶端必須發(fā)送一個(gè)commandText元素 Set N = xml.selectSingleNode("command/commandtext") If N Is Nothing Then Call responseError("Missing ＜commandText＞ parameter.") Else commandText = N.Text End If
' 客戶端必須發(fā)送一個(gè)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
' 創(chuàng)建參數(shù) set nodes = xml.selectNodes("command/param") if nodes is nothing then ' 如果沒(méi)有參數(shù) elseif nodes.length = 0 then ' 如果沒(méi)有參數(shù) 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("創(chuàng)建參數(shù): 不能發(fā)現(xiàn)名稱標(biāo)簽。") 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("參數(shù)名為 '" & paramName & "'的參數(shù)缺少必要的域") end if cm.Parameters.Append cm.CreateParameter(paramName,paramType,paramDirection,paramSize,paramValue) if err.number ＜＞ 0 then call responseError("不能創(chuàng)建或添加名為 '" & paramName & "的參數(shù).' " & err.description) Response.end end if next on error goto 0 end if
'打開連結(jié) set conn = Server.CreateObject("ADODB.Connection") conn.Mode=adModeReadWrite conn.open application("ConnectionString") if err.number ＜＞ 0 then call responseError("連結(jié)出錯(cuò): " & Err.Description) Response.end end if
' 連結(jié)Command對(duì)象 set cm.ActiveConnection = conn
' 執(zhí)行命令 if returnsData then ' 用命令打開一個(gè)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("執(zhí)行命令錯(cuò)誤 '" & Commandtext & "': " & Err.Description) Response.end end if
if returnsData then R.Save Response, adPersistXML if err.number ＜＞ 0 then call responseError("數(shù)據(jù)集發(fā)生存儲(chǔ)錯(cuò)誤，在命令'" & 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 %＞
