set conn = Server.CreateObject("ADODB.Connection")
conn.Mode=adModeReadWrite
conn.open Application("ConnectionString")
set cm.ActiveConnection=conn
' 前往数据
if not returnsData then
cm.Execute
else
set R = server.CreateObject("ADODB.Recordset")
R.CursorLocation = adUseClient
R.Open cm, ,adOpenStatic, adLockReadOnly
end if
if returnsData then
R.Save Response, adPersistXML
if err.number ＜＞ 0 then
call responseError ("数据集产生存储毛病" & "在号令'" & CommandText & "': " & Err.Description)
Response.end
end if
CREATE PROCEDURE RecentPurchaseByCustomerID @CustomerID nchar(5), @ProductName nchar(40) output AS SELECT @ProductName = (SELECT top 1 ProductName FROM Products INNER JOIN ([Order Details] INNER JOIN Orders ON Orders.OrderID=[Order Details].OrderID) ON Products.ProductID = [Order Details].ProductID WHERE Orders.OrderDate = (SELECT MAX(orders.orderdate) FROM Orders
where CustomerID=@CustomerID) AND Orders.CustomerID=@CustomerID) GO
dim s
s = "＜?xml version=""1.0""?＞" & vbcrlf
s = s & "＜command＞＜commandtext＞"
s = s & "CustOrderHist"
s = s & "＜/commandtext＞"
s = s & "＜returnsdata＞" &True＜/returnsdata＞"
s = s & "＜param＞"
s = s & "＜name＞CustomerID＜/name＞"
s = s & "＜type＞＜%=adVarChar%＞＜/type＞"
s = s & "＜direction＞" & ＜%=adParamInput%＞＜/direction＞"
s = s & "＜size＞" & len(CustomerID)& "＜/size＞"
s = s & "＜value＞" & CustomerID &"＜/value＞"
s = s & "＜/param＞"
s = s & "＜/command＞"
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
代码2、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