前面我們已經(jīng)介紹了使用ASP和XML混合編程，那是因?yàn)锳SP頁面能夠很容易讓我們看清應(yīng)用程序正在做什么，但是你如果你不想使用ASP的話，你也可以使用任何你熟悉的技術(shù)去創(chuàng)建一個客戶端程序。下面，我提供了一段VB代碼，它的功能和ASP頁面一樣，也可以顯示相同的數(shù)據(jù)，但是這個VB程序不會創(chuàng)建發(fā)送到服務(wù)器的XML字符串。它通過運(yùn)行一個名叫Initialize的存儲過程，從服務(wù)器取回XML字符串，來查詢ClientCommands表的內(nèi)容。

　　ClientCommands表包括兩個域：command_name域和command_xml域�？蛻舳顺绦蛐枰�三個特定的command_name域:getCustomerList,CustOrderHist和RecentPurchaseByCustomerID。每一個命令的command_xml域包括程序發(fā)送到getData.asp頁面的XML字符串，這樣，就可以集中控制XML字符串了，就象存儲過程名字所表現(xiàn)的意思一樣，在發(fā)送XML字符串到getData.asp之前，客戶端程序使用XML DOM來設(shè)置存儲過程的參數(shù)值。我提供的代碼，包含了用于定義Initialize過程和用于創(chuàng)建ClientCommands表的SQL語句。

　　我提供的例程中還說明了如何使用XHTTPRequest對象實(shí)現(xiàn)我在本文一開始時許下的承諾:任何遠(yuǎn)程的機(jī)器上的應(yīng)用程序都可以訪問getData.asp；當(dāng)然，你也可以通過設(shè)置IIS和NTFS權(quán)限來限制訪問ASP頁面；你可以在服務(wù)器上而不是客戶機(jī)上存儲全局應(yīng)用程序設(shè)置；你可以避免通過網(wǎng)絡(luò)發(fā)送數(shù)據(jù)庫用戶名和密碼所帶來的隱患性。還有，在IE中，應(yīng)用程序可以只顯示需要的數(shù)據(jù)而不用刷新整個頁面。

　　在實(shí)際的編程過程中，你們應(yīng)當(dāng)使用一些方法使應(yīng)用程序更加有高效性。你可以把ASP中的關(guān)于取得數(shù)據(jù)的代碼端搬到一個COM應(yīng)用程序中去然后創(chuàng)建一個XSLT變換來顯示返回的數(shù)據(jù)。好，我不多說了，現(xiàn)在你所要做的就是試一試吧！

　　 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ù)庫返回命令名和相應(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號
　　　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)樗�是一個記錄集
　　　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ā)生錯誤
　
　　　　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對象
　　　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ā)送一個commandText元素
　　　Set N = xml.selectSingleNode("command/commandtext")
　　　If N Is Nothing Then
　　　　Call responseError("Missing ＜commandText＞ parameter.")
　　　Else
　　　　commandText = N.Text
　　　End If

　　　' 客戶端必須發(fā)送一個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
　　　　' 如果沒有參數(shù)
　　　elseif nodes.length = 0 then
　　　　　' 如果沒有參數(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é)出錯: " & Err.Description)
　　　　Response.end
　　　end if

　　' 連結(jié)Command對象
　　set cm.ActiveConnection = conn

　　' 執(zhí)行命令
　　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("執(zhí)行命令錯誤 '" & Commandtext & "': " & Err.Description)
　　　　Response.end
　　　end if

　　　if returnsData then
　　　　R.Save Response, adPersistXML
　　　　if err.number ＜＞ 0 then
　　　　　call responseError("數(shù)據(jù)集發(fā)生存儲錯誤，在命令'" & 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
　　%＞