明辉手游网中心:是一个免费提供流行视频软件教程、在线学习分享的学习平台!

用ASP、VB与XML创建互联网应用程序(4)

[摘要]前面我们已经介绍了使用ASP和XML混合编程,那是因为ASP页面能够很容易让我们看清应用程序正在做什么,但是你如果你不想使用ASP的话,你也可以使用任何你熟悉的技术去创建一个客户端程序。下面,我提供了一段VB代码,它的功能和ASP页面一样,也可以显示相同的数据,但是这个VB程序不会创建发送到服务器...
前面我们已经介绍了使用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
  %>