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