ASP实用大全-实战ASP(8)

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

Option Explicit
Private RCommands As Recordset
Private RCustomers As Recordset
Private RCust As Recordset
Private sCustListCommand As String
Private Const dataURL = 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
= 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

tentType=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

and)
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