BDG Scenario 3

SQLXML.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "SQLXML"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Private flushCount As Long
Public ConnectionString As String
Attribute ConnectionString.VB_VarDescription = "String for connecting to database with winnt authentication."

Private Sub Class_Initialize()
   '--->Using WinNT Authentication
   ConnectionString = "Provider=SQLOLEDB;Server=UELABDC04;Initial Catalog=Eval;Server=UELABDC04;Trusted_Connection=yes"
   'ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=Eval;Data Source=UELABDC04;Server=UELABDC04;DataBase=Eval;Connect Timeout=15;Current Language=us_english;QueryLogFile=yes;APP=Microsoft Development Environment"
End Sub


Public Function ViewRecords(ByRef oRequest As ASPTypeLibrary.Request, _
                            ByRef oResponse As ASPTypeLibrary.Response, _
                            ByRef oServer As ASPTypeLibrary.Server, _
                            Optional ByVal ConnectionString As String)
Attribute ViewRecords.VB_Description = "Takes the SQL query and  converts the SQL Recordset  into XML Stream along with its DTD"
Attribute ViewRecords.VB_UserMemId = 0
   Dim procName$, tableName$, fieldList$, _
       whereID$, sortBy$, search$, qryString$
   
   Dim oRs As ADODB.Recordset
   Dim oCmd As ADODB.Command
   Dim oSearch As LitWare.search
  
   ' Turned on to catch errors
   On Error GoTo ErrHandler
   
   If ConnectionString = "" Then
      ConnectionString = Me.ConnectionString
   End If

   oResponse.Buffer = True
   oResponse.Expires = 0
   
   Set oRs = CreateInstance("ADODB.Recordset")
   
   tableName = oRequest.QueryString("tableName")
   If tableName = "" Or IsEmpty(tableName) Then
   
      procName = oRequest.QueryString("procName")
      If procName = "" Or IsEmpty(procName) Then
         oResponse.Write "<url-error>Missing required parameter: tableName or procName</url-error>"
         oResponse.End
      End If

      Set oCmd = CreateInstance("ADODB.Command")
      With oCmd
         .ActiveConnection = ConnectionString
         .CommandText = procName
         .CommandType = adCmdStoredProc
         .CommandTimeout = 30
         Call AppendParams(oCmd, oRequest)
         Set oRs = .Execute
      End With
      If Err.number <> 0 Then Call reportError(oResponse)

   Else
      fieldList = oRequest.QueryString("fieldList")
      If fieldList = "" Or IsEmpty(fieldList) Then
         fieldList = "*"
      End If
   
      qryString = qryString & "SELECT " & fieldList & " FROM [" & tableName & "] AS t"
      whereID = oRequest.QueryString("whereID")
      
      If Not (whereID = "" Or IsEmpty(whereID)) Then
         qryString = qryString & " WHERE " & tableName & "Id=" & CLng(whereID)
      Else
         'Full-text search
         search = oRequest.QueryString("search")
         If Not (search = "" Or IsEmpty(search)) Then
            Set oSearch = CreateInstance("LitWare.Search")
            oSearch.SearchType = ftsContains
            oSearch.SearchString = search
            qryString = qryString & " WHERE CONTAINS(t.*,N'" & oSearch.SearchString & "')"
         End If
      End If

      sortBy = oRequest.QueryString("sortBy")
      If Not (sortBy = "" Or IsEmpty(sortBy)) Then
         qryString = qryString & " ORDER BY " & sortBy
      End If
         
      Set oRs = CreateInstance("ADODB.Recordset")
      
      'Using adOpenStatic to find the value of RecordCount
      oRs.Open qryString, ConnectionString, adOpenStatic
      If Err.number <> 0 Then Call reportError(oResponse)

   End If
   
   Call EmitDTD(oRs, oResponse)
   
   oResponse.Write "<xmldata>" & vbCrLf
   
   Do Until oRs Is Nothing
      If Not oRs.EOF Then Call Convert(oRs, oResponse, oServer)
      Set oRs = oRs.NextRecordset
   Loop
   
   oResponse.Write "</xmldata>"
   oResponse.End
  
   Exit Function
ErrHandler:
   Err.Raise Err.number, Err.source, Err.description
   End Function

' Emit the Document Type Definition for the XML stream
' NOTE: all recordsets must comply with this definition
' SETS GLOBALS: flushCount
Private Sub EmitDTD(ByRef oRs As ADODB.Recordset, ByRef oResponse As ASPTypeLibrary.Response)
   Dim oField As ADODB.Field
   Dim sRec As String
   Dim recSize As Long
   Dim sSep As String * 1
   
   ' emit DTD (and detect ID field)
   sRec = "<!DOCTYPE xmldata [" & vbCrLf & vbCrLf & _
          "<!ELEMENT xmldata (record)+>" & vbCrLf & _
          "<!ELEMENT record ("
          
   sSep = ""
   For Each oField In oRs.Fields
      sRec = sRec & sSep & oField.name
      If oField.Attributes And adFldIsNullable Then
         sRec = sRec & "?"
      End If
      sSep = ","
   Next
   
   sRec = sRec & ")>" & vbCrLf
   
   ' once more for each field name
   For Each oField In oRs.Fields
      sRec = sRec & "<!ELEMENT " & oField.name & " (#PCDATA)>" & vbCrLf
      recSize = recSize + oField.DefinedSize + Len(oField.name) * 2
   Next
   sRec = sRec & vbCrLf & _
                 "<!ATTLIST record" & vbCrLf & _
                 "          id ID #REQUIRED" & vbCrLf & _
                 " >" & vbCrLf & vbCrLf & _
                 "]>" & vbCrLf & vbCrLf
                 
   oResponse.Write sRec

   ' calculate flush period based on approximate size of record
   flushCount = CInt(4096 / recSize) + 1
End Sub

' Returns the most likely ID field (for use by ID attribute of record)
Private Function GetIDField(ByRef oRs As ADODB.Recordset) As ADODB.Field
   Dim oField As ADODB.Field
   Set GetIDField = Nothing
   For Each oField In oRs.Fields
      If oField.Attributes = adFldFixed Then
         Set GetIDField = oField
         Exit For
      End If
   Next
   If GetIDField Is Nothing Then Set GetIDField = oRs(0)
End Function

' Convert the current recordset to XML stream
' USES GLOBALS: flushCount, oNLS
Private Sub Convert(ByRef oRs As ADODB.Recordset, ByRef oResponse As ASPTypeLibrary.Response, ByRef oServer As ASPTypeLibrary.Server)
   Dim oField As ADODB.Field
   Dim oIDField As ADODB.Field
   Dim oNLS As NLS.Formats
   Dim vValue As Variant
   Dim sRec As String
   Set oNLS = CreateInstance("NLS.Formats")
 
   Set oIDField = GetIDField(oRs)
   
   Do While Not oRs.EOF
      sRec = "<record id='_" & oIDField.value & "'> " & vbCrLf
      For Each oField In oRs.Fields
         vValue = oField.value   ' check for null value carefully, esp. nTEXT type
         If Not (IsNull(vValue) Or vValue = "") Then
            sRec = sRec & "<" & oField.name & ">"
            Select Case oField.Type
            Case adCurrency:
               ' BUG: reformatting insufficient -- must convert value from db locale
               ' BUG: server default locale is used (not user locale)
               sRec = sRec & oNLS.FormatLocaleCurrency(0, vValue)
            Case adDate, adDBDate, adDBFileTime, adDBTime, adDBTimeStamp, adFileTime:
               ' BUG: time value does not incorporate timezone info
               ' BUG: server default locale is used (not user locale)
               sRec = sRec & oNLS.FormatLocaleDateTime(0, vValue)
            Case adDecimal, adDouble, adNumeric:
               ' BUG: server default locale is used (not user locale)
               sRec = sRec & oNLS.FormatLocaleNumber(0, vValue)
            Case adChapter:
               ' Hierarchical recordset, make recursive call
               'If Not vValue.EOF Then Call Convert(vValue, oResponse,oServer)
            Case Else:
               ' Treat all other records as text
               sRec = sRec & oServer.HTMLEncode(vValue)
            End Select
            sRec = sRec & "</" & oField.name & ">" & vbCrLf
         End If
      Next
      sRec = sRec & "</record>" & vbCrLf
      oResponse.Write sRec
      If oRs.RecordCount Mod flushCount = 0 Then oResponse.Flush
      oRs.MoveNext
   Loop
   
End Sub

' Copy stored proc parameters from QueryString (URL)
' SET GLOBALS: oCmd.Parameters
Private Sub AppendParams(ByRef oCmd As ADODB.Command, ByRef oRequest As ASPTypeLibrary.Request)
   Dim param As ADODB.Parameter
   Dim name As String
   Dim value As Variant
   With oCmd
      .Parameters.Refresh
      'Copy values frm FORM into PARAMETERS collection
      For Each param In .Parameters
         If param.Direction = adParamInput Then
            name = Mid(param.name, 2)
            value = oRequest.QueryString(name)
            'oResponse.Write "DEBUG: url value '" & name & "' = '" & value & "'<BR>"
            param.value = value
         End If
      Next
   End With
End Sub

' Format error, and END
Private Sub reportError(ByRef oResponse As ASPTypeLibrary.Response)
   oResponse.Write "<xmldata>" & vbCrLf & _
                  "<error>" & vbCrLf & _
                  "<number>" & Hex(Err.number) & "</number>" & vbCrLf & _
                  "<description>" & Err.description & "</description>" & vbCrLf & _
                  "<source>" & Err.source & "</source>" & vbCrLf & _
                  "</error>" & vbCrLf & _
                  "</xmldata>"
   oResponse.End
End Sub

Public Sub PostActions(ByRef oRequest As ASPTypeLibrary.Request, ByRef oResponse As ASPTypeLibrary.Response, Optional ByVal ConnectionString As String)
Attribute PostActions.VB_Description = "Captures the action required on database and calls appropriate stored procedure and maps input parameters of stored procedure with the form submitted values. Lastly calls the client script to update UI reflecting changed data."
 Dim returnId$
 Dim oCommand As ADODB.Command
 Dim nameSProc As Variant
   
On Error Resume Next

If ConnectionString = "" Or IsEmpty(ConnectionString) Then
   ConnectionString = Me.ConnectionString
End If

nameSProc = oRequest.Form("procName")
If nameSProc = "" Or IsEmpty(nameSProc) Then
   oResponse.Write "ERROR: must specify 'procName'."
   oResponse.End
End If

Set oCommand = CreateInstance("ADODB.Command")
With oCommand
   .ActiveConnection = ConnectionString
   .CommandType = adCmdStoredProc
   .CommandTimeout = 30

   For Each nameSProc In oRequest.Form("procName")
      .CommandText = nameSProc
      Select Case UCase(oRequest.Form("actionBtn"))
      Case "ADD"
         'oResponse.Write "DEBUG: adding record with '" & nameSProc & "'<BR>"
         Call execForm(oCommand, oRequest, oResponse)
         Call reportErrors(oCommand, oResponse)
         returnId = oCommand.Parameters("@" & oRequest.Form("tableName") & "Id")
         'oResponse.Write "DEBUG: new record id = " & returnId & "<BR>"
         Call updateView("ADD", returnId, oResponse)
      Case "CHANGE"
         'oResponse.Write "DEBUG: updating record with '" & nameSProc & "'<BR>"
         returnId = oRequest.Form("Id")
         oResponse.Write "DEBUG: record id = " & returnId & "<BR>"
         Call execForm(oCommand, oRequest, oResponse)
         Call reportErrors(oCommand, oResponse)
         Call updateView("CHANGE", returnId, oResponse)
      Case "DELETE"
         'oResponse.Write "DEBUG: deleting record with '" & nameSProc & "'<BR>"
         returnId = oRequest.Form("Id")
         'oResponse.Write "DEBUG: record id = " & returnId & "<BR>"
         .Parameters.Append .CreateParameter("@" & oRequest.Form("tableName") & "Id", adInteger, adParamInput, 4, returnId)
         .Execute
         Call reportErrors(oCommand, oResponse)
         Call updateView("DELETE", returnId, oResponse)
      Case Else
         oResponse.Write "ERROR: Unknown actionBtn value." & vbCrLf
         oResponse.End
      End Select

   Next ' NEXT PROCEDURE
   
End With
   
Set oCommand = Nothing
End Sub
Private Sub execForm(ByRef oCommand As ADODB.Command, ByRef oRequest As ASPTypeLibrary.Request, ByRef oResponse As ASPTypeLibrary.Response)
Dim param As ADODB.Parameter
Dim rparam As ADODB.Parameter

Dim name$, rname$
Dim value As Variant

Set rparam = Nothing
On Error Resume Next

With oCommand
   .Parameters.Refresh
   'Copy values frm FORM into PARAMETERS collection
   For Each param In .Parameters
      'oResponse.Write "PARAM: " & param.name & " TYPE:" & param.Type & "<BR>"
      If param.Direction = adParamInput Then
         name = Mid(param.name, 2)
         If oRequest.Form(name).count <= 1 Then
            value = Trim(oRequest.Form(name))
            If value = "" Or value = "null" Then value = Null
            'oResponse.Write "DEBUG: form value '" & name & "' = '" & value & "'<BR>"
            param.value = value
         Else
            'Come back to this one in a loop later
            If rparam Is Nothing Then
               rname = name
               Set rparam = param
               oResponse.Write "DEBUG: repeated value.<BR>"
            Else
               oResponse.Write "ERROR: Only one repeater value may be specified by the form.<BR>"
               oResponse.End
            End If
         End If
      End If
   Next

   If Not (IsEmpty(rname) Or rparam Is Nothing) Then
      'Execute in a loop...
      For Each value In oRequest.Form(rname)
         value = Trim(value)
         If value = "" Or value = "null" Then value = Null
         oResponse.Write "DEBUG: repeater form value '" & name & "' = '" & value & "'<BR>"
         rparam.value = value
         .Execute
      Next
   Else
      'No repeated values, just execute
      .Execute
   End If
End With
End Sub

Private Sub updateView(ByVal actn As String, ByVal id As String, ByRef oResponse As ASPTypeLibrary.Response)
   If id = "" Or IsEmpty(id) Then id = "null"
   oResponse.Write "<" & "script language=""JavaScript"">" & vbCrLf & _
                  "parent.window.updateView(""" & actn & """," & id & ");" & vbCrLf & _
                  "</" & "script>"
End Sub

Private Sub reportErrors(ByRef oCommand As ADODB.Command, ByRef oResponse As ASPTypeLibrary.Response)
   Dim sMsg As String
   Dim ERROR As ADODB.ERROR
   
   If Err.number <> 0 Then
      Call writeError(Err.number, Err.description, Err.source, oResponse)
      oResponse.End
   ElseIf oCommand.ActiveConnection.Errors.count > 0 Then
      For Each ERROR In oCommand.ActiveConnection.Errors
         Call writeError(ERROR.number, ERROR.description, ERROR.source, oResponse)
      Next
      oResponse.End
   End If
End Sub

Private Sub writeError(ByVal number As Long, ByVal description As String, ByVal source As String, ByRef oResponse As ASPTypeLibrary.Response)
   Dim sMsg As String
   sMsg = source & ": error " & Hex(number) & "\n" & description & "\n"
   sMsg = Replace(sMsg, "'", "\'") ' so javaScript isn't confused
   oResponse.Write "<" & "script language=""JavaScript"">" & vbCrLf & _
                  "alert('" & sMsg & "');" & vbCrLf & _
                  "</" & "script>"
End Sub