ClientCommands表包括两个域：command_name域和command_xml域。客户端程序需要三个特定的command_name域:getCustomerList,CustOrderHist和RecentPurchaseByCustomerID。每一个命令的command_xml域包括程序发送到getData.asp页面的XML字符串，这样，就可以集中控制XML字符串了，就象存储过程名字所表现的意思一样，在发送XML字符串到getData.asp之前，客户端程序使用XML DOM来设置存储过程的参数值。我提供的代码，包含了用于定义Initialize过程和用于创建ClientCommands表的SQL语句。

我提供的例程中还说明了如何使用XHTTPRequest对象实现我在本文一开始时许下的承诺:任何远程的机器上的应用程序都可以访问getData.asp；当然，你也可以通过设置IIS和NTFS权限来限制访问ASP页面；你可以在服务器上而不是客户机上存储全局应用程序设置；你可以避免通过网络发送数据库用户名和密码所带来的隐患性。还有，在IE中，应用程序可以只显示需要的数据而不用刷新整个页面。

在实际的编程过程中，你们应当使用一些方法使应用程序更加有高效性。你可以把ASP中的关于取得数据的代码端搬到一个COM应用程序中去然后创建一个XSLT变换来显示返回的数据。好，我不多说了，现在你所要做的就是试一试吧！

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