用ASP、VB和XML建立互联网应用程序

在个人电脑上使用单机版应用软件的时代很快就要过去了，现在大部分的应用程序都开发出网络版或大都需要共享网络上丰富的数据资源。我们虽然写了很长时间基于客户端/服务器的应用程序，但是这些程序大部分只是运行在小型的局域网内部。然而，有很多客观的原因要求我们要修改这些程序以使它们能够运行在一个企业的内部网甚至是国际互联网。

是什么原因迫使我们做呢？首先，随着一个企业的规模逐渐扩大，公司可能会跨地区甚至跨国经营，每个分公司的员工的数量也会逐年增多，这些在外地的员工肯定需要频繁地访问总公司的数据库资源；其次，集中应用程序的数据资源，能够使你更好的监控数据库的访问和使用情况。第三，你可以通过从一个集中的位置获取全局应用程序设置，从而维护和更新它们，最终达到缓减应用程序更新的目的。第四，尽量从Web服务器上访问数据库而不是从客户端上访问数据库，这样可以避免通过网络传送登录信息和客户密码，从而避免安全隐患；而且，使用浏览器从后台获取数据，这样能够避免刷新整个页面。

这就要求我们创建一个运行于互联网上的应用程序，而假如想创建一个运行在HTTP协议上的VB程序，那么关键就是使用XML和XMLHTTPRequest对象。这个对象是Microsoft XML分析器（msxml.dll）的一部分，XMLHTTPRequest对象可以让你通过HTTP向远程服务器发送GET和POST请求，运行在远程服务器上的程序接收这个请求，翻译出它的内容，返回数据或者一个错误页面到调用它的应用程序。对网络编程有一些研究的朋友会看出我这个设想很象SOAP，但是在这里我不想使用SOAP，因为如果那样的话会使程序变得很复杂。

想要改变一个完全独立的客户端单机版程序是不太现实的，但即使如此，从一个集中的服务器上下载应用程序设置也比使用本地的INI文件或Windows注册标有更大的独立性和灵活性。举例来说，假设你有一支手机销售队伍，他们需要访问集中化的信息来更有效的销售手机，每天，总公司集中收集数据，然后用电子邮件的形式发送给销售人员。然而，市场的压力和迅速变化的销售形式势必使销售人员要访问最新的数据信息。但是，网络管理员却坚持拒绝让在远程客户端的销售人员访问总公司数据库服务器，因为他们不想通过公用的网络发送用户名和登录密码。因此势必要使用一种新的技术代替基于客户端/服务器的技术，不要着急，我想看完本文你就会解决这个问题的。

让我们先分析一下客户端/服务器应用程序。在一个标准的客户端/服务器应用程序中，在应用程序开始时，你能够初始化数据库连接字符串，这就意味着，客户有使用数据库连接字符串的权利，这包括用户名和口令。但是客观情况如果不允许你在网络上发送这些信息的话，你就必需在不联接数据库的情况下直接从客户端取得数据发送给客户。那么解决方案之一就是在服务器上创建一个ASP页（在本例中称为getData.asp）接收特定格式的POST数据，它要求一个包含XML字符串，用来创建ADO对象并运行存储过程或动态SQL语句命令。如果信息有效的话，getData.asp执行存储过程，并返回一个XML格式的数据集、返回值列表或错误页面信息的XML字符串。对于返回数据的命令，客户端要么重新实例化要么返回值或使用XML DOM(Document Object Model文档对象模型）格式的错误页面。

好，下面就让我们来讨论一下如何实现这个页面吧！

getData.asp页面首先使用一个DOMDocument对象来保存客户端发送的数据：

''创建DOMDocument对象
Set xml = Server.CreateObject ("msxml2.DOMDocument")
xml.async = False

然后，它装载POST数据

''装载POST数据
xml.Load Request
If xml.parseError.errorCode ＜＞ 0 Then
　 Call responseError ("不能装载XML信息。" & "Description: " & xml.parseError.reason & "＜br＞Line: " & xml.parseError.Line)
End If

　 它能够返回commandtext元素值和returndata或returnvalue元素值。下面我只给出返回commandtext元素值的代码，其余代码请参看我下面所附的源程序。

Set N = xml.selectSingleNode("command/commandtext")
If N Is Nothing Then
　 Call responseError ("缺少 ＜sp_name＞ 参数。")
Else sp_name = N.Text
End If

接着，应该让页面创建一个Command对象，读入所有＜param＞元素，并且为request中的每一个元素创建一个参数。最后，让页面打开一个连接使用存储过程adExecuteNoRecords选项来执行request。

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

如果能够返回数据的话，那么returnData变量就为真值，并且把结果数据集返回到客户端，仍然是一个XML文档。

if returnsData then
　 R.Save Response, adPersistXML
if err.number ＜＞ 0 then
　 call responseError ("数据集发生存储错误" & "在命令''" & CommandText & "'': " & 　Err.Description)
　 Response.end
end if

如果输出参数返回值，那么这个页面将返回一个包含这些值的XML字符串。文档的根元素是一个＜values＞标记，每一个返回值都有其相应的子元素，如果发生任何错误，页面都会格式化并返回一个包含错误信息的XML字符串：

Sub responseError(sDescription)
　 Response.Write "＜response＞＜data＞错误: " & sDescription & "＜/data＞＜/response＞"
　 Response.end
End Sub

假设在我们前面所说的例子中，我们想在应用程序中显示区域的左半边显示客户的姓名列表，再在每个客户姓名后面加上两个链接：Purchase History和Recent Purchase。当用户点击其中的一个链接，客户程序就会运行一个存储过程并在右边区域显示出结果。 为了显示这个想法的灵活性，我想让用于返回数据的三个操作单元执行不同的工作过程，它们都调用getData.asp。首先，通过调用CustOrderHist来运行一个存储过程，返回客户的Purchase History，它搜索Northwind数据库（为了方便起见我使用MS SQL中自带的数据库）并返回一个数据集。用于返回Recent Purchase 的查询语句运行一个叫RecentPurchaseByCustomerID的存储过程，来接收输入的CustomerID参数并通过ProductName参数返回最近顾客购买的商品名。定义其处理过程相应SQL语句如下：
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

不管你的查询语句中含有动态SQL语句还是含有返回记录集的存储过程或是输出一个返回值，其处理POST消息的方法是一样的：

set xhttp = createObject ("msxml2.XMLHTTP")
xhttp.open "POST", "http://localhost/myWeb/ getData.asp", False
xhttp.send s

好了，现在让我们看一看如何发送和接收数据

客户端的XML信息是由一个＜command＞元素和一些子元素组成：＜commandtext＞元素包含了存储过程的名称，＜returnsdata＞元素告诉服务器，客户端是否要求接收返回数据，＜param＞元素包含参数信息。如果不使用参数的话，那么最简单的发送字符串查询就象下面这样：

＜command＞
　 ＜commandtext＞

存储过程或动态SQL语句

＜/commandtext＞
　 ＜returnsvalues＞True＜/returnsvalues＞
＜/command＞

你可以为每一个参数使用一个＜param＞元素，来添加参数。每个＜param＞元素有五个子元素：name，type，direction，size和value。子元素的顺序可以随意调换，但是所有的元素都应当有不能缺少，我通常按照定义一个ADO对象的值的顺序来定义它们。举例来说，CustOrderHist存储过程需要一个CustomID参数，所以用来创建发送到getData.asp的XML字符串的代码为：

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＞"

注意，前面的代码都是客户端代码，ADO常量是不在客户端定义的-这就是它们为什么使用＜% %＞标记围起来的原因。服务器在发送响应之前使用正确的值取代它们。getData.asp页有一个Response.ContentType，它的属性为"text/xml",这样，你就可以使用ResponseXML属性来返回结果了。当请求返回纪录，你就可以创建一个Recordset对象并且使用XMLHTTP来打开它：

Dim R
　 set R = createObject("ADODB.Recordset")
　 R.open xhttp.responseXML

当查询语句返回数据时，通过设置XMLHTTPRequest对象的responseXML属性来创建一个DOMDocument：

Dim xml
　 set xml = xhttp.responseXML

输出参数的XML字符串的每个返回值都包含一个元素，它们都是根元素＜values＞的直接子元素，例如：

＜?xml version=""1.0"" encoding=""gb2312""?＞
＜values＞
＜paramname＞value＜/paramname＞
　 ＜paramname＞value＜/paramname＞
＜/values＞

如果你的数据使用别的国家的文字，你可能需要把编码属性用相应的编码替换，例如对于大部分欧洲语言，可以使用ISO-8859-1

客户端页面使用返回的数据来格式化一个HTML字符串用于显示，如：

document.all("details").innerHTML = ＜一些格式化的HTML字符串＞

前面我们已经介绍了使用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
%＞