• Home
 · 
• Active Server Pages
 · 
• Convert ADO Rs into an HTML

Convert ADO Rs into an HTML

Convert ADO Rs into an HTML

Rate Convert ADO Rs into an HTML

• 1
• 2
• 3
• 4
• 5

(3(3 Vote))

    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