当前位置导航:炫浪网>>网络学院>>网页制作>>ASP教程

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 = "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
  %>

相关内容
赞助商链接