用ASP、VB和XML建立互联网应用程序4 -pc6资讯

您的位置：首页 → 网页设计 → ASP实例 → 用ASP、VB和XML建立互联网应用程序4

用ASP、VB和XML建立互联网应用程序4 时间：2004/11/7 2:54:00来源：本站整理作者：蓝点我要评论(0): 前面我们已经介绍了使用ASP和XML混合编程，那是因为ASP页面能够很容易让我们看清应用程序正在做什么，但是你如果你不想使用ASP的话，你也可以使用任何你熟悉的技术去创建一个客户端程序。下面，我提供了一段VB代码，它的功能和ASP页面一样，也可以显示相同的数据，但是这个VB程序不会创建发送到服务器的XML字符串。它通过运行一个名叫Initialize的存储过程，从服务器取回XML字符串，来查询ClientCommands表的内容。

　　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

　　　set cm = nothing

　　　conn.Close

　　　set R = nothing

　　　set conn = nothing

　　　Response.end

　　%＞

文章评论

查看所有0条评论>>

热门文章 没有查询到任何记录。