by Steven E. Farkas (1 Submission)
Category: Active Server Pages
Compatability: ASP (Active Server Pages)
Difficulty: Unknown Difficulty
Originally Published: Tue 13th February 2001
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Convert ADO Rs into an HTML
VBcoders
strHtmlElemName, _
strSelectedItem, _
anHtmlEvent, _
strJavaScript) 'As String
' Function RsToHtmlCombo(oRs As ADODB.Recordset, _
' strHtmlElemName As String, _
' Optional strSelectedItem As String = "", _
' Optional anHtmlEvent As HtmlEvents, _
' Optional strJavaScript As String = "") As String
'Public Enum HtmlEvents
' OnClick = 1
' OnChange = 2
'End Enum
On Error Resume Next 'GoTo ErrHandler
'Input: oRs is a recordset with either one field
' or two fields. The first field is the
' value arguement for <OPTION VALUE=
' When there is a second field, the
' second field is what is displayed by HTML
Dim sHTML 'As String
Dim sOpt 'As String
Dim oFDdis 'As ADODB.Field
Dim oFDval 'As ADODB.Field
Dim bMoreThanOne 'As Boolean
Dim bSelectedStr 'As Boolean
Const SelBegin = "<SELECT name=theName>"
Const SelOpt = "<OPTION VALUE=theValue>DisplayThis</OPTION>"
Const SelOptFirst = "<OPTION VALUE=initial></OPTION>"
Const selEnd = "</SELECT>"
'-------------------------------------------------
sHTML = SelBegin & vbCrLf & SelOptFirst
'With oRs
Set oFDval = oRs.Fields(0)
bMoreThanOne = oRs.Fields.Count > 1
bSelectedStr = Len(Trim(strSelectedItem)) > 0
If bSelectedStr Then sHTML = SelBegin & vbCrLf
If bMoreThanOne Then
Set oFDdis = oRs.Fields(1)
Do Until oRs.EOF
sOpt = Replace(SelOpt, "theValue", Chr(34) & oFDval.Value & Chr(34))
sOpt = Replace(sOpt, "DisplayThis", oFDdis.Value)
If bSelectedStr Then 'GoSub MarkAsSelected
'If UCase(sOpt) Like "*" & Trim(strSelectedItem) & ">*" Or sOpt Like "*" & Trim(strSelectedItem) & ">*" Then
If InStr(UCase(oFDval.Value), UCase(Trim(strSelectedItem))) > 0 Or InStr(oFDval.Value, Trim(strSelectedItem)) > 0 Then
'assumes that strSelectedItem is unique and is
'not a substring of any other HTML OPTION
'sOpt = Replace(UCase(sOpt), "OPTION VALUE", "OPTION SELECTED VALUE")
sOpt = Replace(sOpt, "OPTION VALUE", "OPTION SELECTED VALUE")
End If
End If
sHTML = sHTML & sOpt
oRs.MoveNext
Loop
Else
Do Until oRs.EOF
sOpt = Replace(SelOpt, "theValue", Chr(34) & oFDval.Value & Chr(34))
sOpt = Replace(sOpt, "DisplayThis", oFDval.Value)
If bSelectedStr Then 'GoSub MarkAsSelected
'If UCase(sOpt) Like "*" & Trim(strSelectedItem) & ">*" Or sOpt Like "*" & Trim(strSelectedItem) & ">*" Then
If InStr(UCase(oFDval.Value) & ">", UCase(Trim(strSelectedItem)) & ">") > 0 Or InStr(oFDval.Value & ">", Trim(strSelectedItem) & ">") > 0 Then
'assumes that strSelectedItem is unique and is
'not a substring of any other HTML OPTION
'sOpt = Replace(UCase(sOpt), "OPTION VALUE", "OPTION SELECTED VALUE")
sOpt = Replace(sOpt, "OPTION VALUE", "OPTION SELECTED VALUE")
End If
End If
sHTML = sHTML & vbCrLf & sOpt & vbCrLf
oRs.MoveNext
Loop
End If
'End With
If Len(Trim(strJavaScript)) > 0 Then
'assumes that strJavaScript comes as a legitimate
'javascript function, e.g., "MyFunc(MyArgs);"
Select Case anHtmlEvent
Case 1 ' onClick
sHTML = Replace(sHTML, "<SELECT ", "<SELECT onClick=" & Chr(34) & strJavaScript & Chr(34) & Space(1))
Case 2 ' onChange
sHTML = Replace(sHTML, "<SELECT ", "<SELECT onChange=" & Chr(34) & strJavaScript & Chr(34) & Space(1))
End Select
End If
If Len(Trim(strHtmlElemName)) > 0 Then
sHTML = Replace(sHTML, "theName", strHtmlElemName)
End If
' GoTo CleanUp
'ErrHandler:
' Err.Raise Err.Number, Err.Source, Err.Description & " from clsCommonFunctions.RsToHtmlTable."
'CleanUp:
ASPRsToHtmlCombo = sHTML & vbCrLf & selEnd
Exit Function
'MarkAsSelected:
' If UCase(sOpt) Like "*" & Trim(strSelectedItem) & ">*" Or sOpt Like "*" & Trim(strSelectedItem) & ">*" Then
' 'assumes that strSelectedItem is unique and is
' 'not a substring of any other HTML OPTION
' sOpt = Replace(UCase(sOpt), "OPTION VALUE", "OPTION SELECTED VALUE")
' End If
' Return
End Function
