rothen ecotronics Bern: ASP-Skript "ASP Datenbankanbindung: Generisches Formular für beliebige Tabellen"

<%@ Language=VBScript %>
<%
'Option Explicit
Response.Expires = 0
'On Error Resume Next

'Datenbankanbindung ohne ODBC
'geht nur, wenn auf Webserver ein Access-Treiber installiert ist!

Dim arrPKs
Dim arrSpecialFields
Dim dicMeldungen
Set dicMeldungen = CreateObject("Scripting.Dictionary")

Dim objcon
Dim strcon
Dim strTablename
strTablename = "tblfieldtest"

arrPKs = Array(Array("Autowert", "1"), Array("PKText", "xeuez"))

arrSpecialFields = Array( _
  Array("UpdateDate", "function", "now()"), _
  Array("Special", "value", "15" ), _
  Array("Null", "null", ""), _
  Array("NoUpdate", "noupdate", ""))

Set objcon = Server.CreateObject("ADODB.Connection")
strcon = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
  "Data Source=" & Server.MapPath("/asppages/silvi/db/dbfieldtest.mdb")

'Response.Write strcon
objcon.Open strcon

'Recordset geöffnet?
Const adStateOpen = &H00000001

'Filterkriterium
Const adFilterNone = 0

'Schema
Const adSchemaColumns = 4
Const adSchemaProviderTypes = 22
Const adSchemaPrimaryKeys = 28

'Datentypen Recordset
Const adEmpty =              0
Const adSmallInt =           2
Const adInteger =            3
Const adSingle =             4
Const adDouble =             5
Const adCurrency =           6
Const adDate =               7
Const adBSTR =               8
Const adIDispatch =          9
Const adError =             10
Const adBoolean =           11
Const adVariant =           12
Const adIUnknown =          13
Const adDecimal =           14
Const adTinyInt =           16
Const adUnsignedTinyInt =   17
Const adUnsignedSmallInt =  18
Const adUnsignedInt =       19
Const adBigInt =            20
Const adUnsignedBigInt =    21
Const adGUID =              72
Const adBinary =           128
Const adChar =             129
Const adWChar =            130
Const adNumeric =          131
Const adUserDefined =      132
Const adDBDate =           133
Const adDBTime =           134
Const adDBTimeStamp =      135
Const adVarChar =          200
Const adLongVarChar =      201
Const adVarWChar =         202
Const adLongVarWChar =     203
Const adVarBinary =        204
Const adLongVarBinary =    205

'Feldattribute
Const adFldMayDefer = &H00000002
Const adFldUpdatable = &H00000004
Const adFldUnknownUpdatable = &H00000008
Const adFldFixed = &H00000010
Const adFldIsNullable = &H00000020
Const adFldMayBeNull = &H00000040
Const adFldLong = &H00000080
Const adFldRowID = &H00000100
Const adFldRowVersion = &H00000200

'*****************************************************************
Function funStrValueAusSchema(ByVal rsSchema, ByVal strFilter, ByVal strField, ByVal strNVL)
  Dim strHelp
  'Response.Write(strFilter & " " & strField & " " & strNVL & "<br /> <br />" & vbCrLf)

  rsSchema.Filter = strFilter
  If Not rsSchema.EOF Then
    strHelp = rsSchema(strField) 'für Pre-/Suffix
  Else
    strHelp = strNVL
  End If
  rsSchema.Filter = adFilterNone
  funStrValueAusSchema = strHelp
  'Response.Write("strHelp in funStrValueAusSchema: " & strHelp & "<br /> <br />" & vbCrLf)
End Function

'Gibt erste Zeilennummer des Arrays zurück, in dem ein Testwert gefunden wird und -1, wenn nicht gefunden
Function funIntInArray(ByVal arrFelder, ByVal strTest, ByVal intCol)
  Dim intCounter

  funIntInArray = -1

  If IsArray(arrFelder) Then
    For intCounter = 0 To Ubound(arrFelder)
      If arrFelder(intCounter)(intCol) = strTest Then
        funIntInArray = intCounter
        Exit For
      End If
    Next
  End If
End Function

'**********************************************************************************************************
'Schreibt ein generisches Formular
'arrPKs: 2 Spalten, erste Spalte Feldname, 2. Spalte Wert
'arrSpecialFields: 3 Spalten, 1) Feldname 2) Was passiert (function, value, null oder noupdate)
'  3) Wert für function oder value
Sub procGenericForm(ByVal blnInsert, ByVal objcon, ByVal strTableName, ByVal arrPKs, _
  ByVal arrSpecialFields, ByRef dicMeldungen, ByVal intBorder)

  Const INTDEFAULTSIZE = 40

  Dim blnFirst
  Dim intCounter
  Dim intArrPos
  Dim intSize
  Dim objfield
  Dim objrs
  Dim objProperty
  Dim rsSchemaColumns
  Dim rsSchemaPrimaryKeys
  Dim rsSchemaProviderTypes
  Dim strColAutowert
  Dim strColDataType 'Datentyp einer Spalte aus Schema, nicht gleich wie Recordset
  Dim strColDefault
  Dim strColIs_Nullable
  Dim strColPKOrdinal
  Dim strColPrefix
  Dim strColSuffix
  Dim strFieldAttributes
  Dim strPrimaryKeys
  Dim strsql

  blnFirst = true

  Set rsSchemaColumns = objcon.OpenSchema(adSchemaColumns)
  Set rsSchemaPrimaryKeys = objcon.OpenSchema(adSchemaPrimaryKeys)
  Set rsSchemaProviderTypes = objcon.OpenSchema(adSchemaProviderTypes) 'Datentypen

  'Primärschlüsselstring
  strPrimaryKeys = funStrPrimaryKeys(strcon, strTablename)
  'Response.Write("PK: " & strPrimaryKeys & "<br /> <br />" & vbCrLf)

  'Select
  strsql = "SELECT * FROM " & strTablename
  If isArray(arrPKs) Then
    'Response.Write("Ubound: " & Ubound(arrPKs) & "<br /> <br />" & vbCrLf)
    For intCounter = 0 To UBound(arrPKs) - 1
      If arrPKs(intCounter)(0) <> "" Then
        strColDataType = funStrValueAusSchema(rsSchemaColumns, _
          "TABLE_NAME = '" & strTablename & "' AND COLUMN_NAME = '" & arrPKs(intCounter)(0)& "'", "DATA_TYPE", "")
        'Response.Write(arrPKs(intCounter)(0) & strColDataType & "<br /> <br />" & vbCrLf)

        strColPrefix = funStrValueAusSchema(rsSchemaProviderTypes, _
          "DATA_TYPE = " & strColDataType, "LITERAL_PREFIX", "")

        strColSuffix = funStrValueAusSchema(rsSchemaProviderTypes, _
          "DATA_TYPE = " & strColDataType, "LITERAL_SUFFIX", "")

        If blnFirst Then
          blnFirst = False
          If blnInsert Then
            strSQL = strSQL & " WHERE " & arrPKs(intCounter)(0) & " IS Null"
          Else
            strSQL = strSQL & " WHERE " & arrPKs(intCounter)(0) & " = " & _
              strColPrefix & arrPKs(intCounter)(1) & strColSuffix
          End If
        Else
          If blnInsert Then
            strSQL = strSQL & " AND " & arrPKs(intCounter)(0) & " IS Null"
          Else
            strSQL = strSQL & " AND " & arrPKs(intCounter)(0) & " = " & _
              strColPrefix & arrPKs(intCounter)(1) & strColSuffix
          End If
        End If
      End If
    Next
  End If

  strColDataType = ""


  Response.Write("<form method=""POST"" action=""" & _
    Right(Request.ServerVariables("URL"), Len(Request.ServerVariables("URL")) _
    - InStrRev(Request.ServerVariables("URL"),"/")) & """>" & vbCrLf)
  Response.Write("  <input type=""hidden"" name=""fldstrSQL"" value=""" & strSQL & """ />" & vbCrLf)
  Response.Write("  <input type=""hidden"" name=""fldstrtablename"" value=""" & strTableName & """ />" & vbCrLf)
  Response.Write("  <input type=""hidden"" name=""fldblninsert"" value=""" & blninsert & """ />" & vbCrLf)

  Set objrs = Server.CreateObject("ADODB.Recordset")
  objrs.Open strsql, objcon, 1, 3
  If blnInsert Then
    objrs.AddNew
  End If
  If IsObject(objRS) Then
    If objRS.State = adStateOpen Then
      Response.Write("  <table border=""" & intBorder & """>" & vbCrLf)
      If Not objRS.EOF Then
        '**************************************************************************
        For each objField In objRS.Fields

          'Column-Eigenschaften aus Schema Columns bestimmen
          rsSchemaColumns.Filter = "TABLE_NAME = '" & strTablename & "' AND COLUMN_NAME = '" & objField.Name & "'"
          If Not rsSchemaColumns.EOF Then
            strColDataType = rsSchemaColumns("DATA_TYPE") 'für Pre-/Suffix
            strColDefault = rsSchemaColumns("COLUMN_DEFAULT")
            strColIs_Nullable = rsSchemaColumns("IS_NULLABLE")
          Else
            strColDataType = " "
            strColDefault = " "
            strColIs_Nullable = " "
          End If
          rsSchemaColumns.Filter = adFilterNone

          'Primärschlüssel aus Schema PrimaryKeys
          strColPKOrdinal = funStrValueAusSchema(rsSchemaPrimaryKeys, _
            "TABLE_NAME = '" & strTablename & "' AND COLUMN_NAME = '" & objField.Name & "'", "ORDINAL", " ")

          'Pre- und Suffix aus Schema ProviderTypes
          strColPrefix = funStrValueAusSchema(rsSchemaProviderTypes, _
            "DATA_TYPE = " & strColDataType, "LITERAL_PREFIX", "")
          strColPrefix = funStrValueAusSchema(rsSchemaProviderTypes, _
            "DATA_TYPE = " & strColDataType, "LITERAL_SUFFIX", "")

          strColAutowert = objField.Properties("ISAUTOINCREMENT")

          If Not IsNull(objField.Value) Then
            strPrimaryKeys = Join(Split(strPrimaryKeys, "|" & objField.Name & "|"), _
              strColPrefix & objField.Value & strColSuffix)
          End If

          '******************************************************************
          Response.Write("    <tr>" & vbCrLf)

          'Feldname
          Response.Write("      <td valign=""top"">" & vbCrLf)
          Response.Write("        " & objField.Name & vbCrLf)
          Response.Write("      </td>" & vbCrLf)


          'Eingabe- oder Anzeigefelder
          Response.Write("      <td valign=""top"">" & vbCrLf)
          If CBool(objField.Attributes And adFldUpdatable) Then
            intArrPos = funIntInArray(arrSpecialFields, objField.Name, 0)
            If intArrPos >= 0 Then
              'Spezialwerte eintragen mit Select Case
              Select Case arrSpecialFields(intArrPos)(1)
                Case "function"
                  'Function wird bereits hier ausgewertet -> Now() ist immer etwas zu früh!
                  Response.Write(space(8) & Eval(arrSpecialFields(intArrPos)(2)) & vbCrLf & space(8) &_
                    "<input type=""hidden"" name=""" & objField.Name & """ value=""" & _
                    Eval(arrSpecialFields(intArrPos)(2)) & """ /> " & vbCrLf)
                    'arrSpecialFields(intArrPos)(2) & """ /> " & vbCrLf)
                Case "value"
                  Response.Write(space(8) & arrSpecialFields(intArrPos)(2) & vbCrLf & space(8) &_
                    "<input type=""hidden"" name=""" & objField.Name & """ value=""" & _
                    arrSpecialFields(intArrPos)(2) & """ /> " & vbCrLf)
                Case "null"
                  Response.Write(space(8) & "null" & vbCrLf)
                  If strColIs_Nullable Then
                    Response.Write(space(8) & _
                      "<input type=""hidden"" name=""" & objField.Name & _
                      """ value=""null"" />" & vbCrLf &vbCrLf)
                  End If
                Case "noupdate"
                  Response.Write(space(8) & objField.Value & " " & vbCrLf)
                Case Else
                  Response.Write(space(8) & objField.Value & " " & vbCrLf)
              End Select
            Else
              'Default-Werte für neue Datensätze
              If blnInsert And strColDefault <> "" Then
                objField.Value = strColDefault
              End If

              If objField.Type = adLongVarWChar Then
                'Für Memofelder mehrzeiliges Textfeld
                Response.Write("        <textarea rows=""4"" name=""" & objField.Name & _
                  """ cols=""40"">" & objField.Value & "</textarea>" & vbCrLf)
              ElseIf objField.Type = adBoolean Then
                'Für boolsche Felder Kombinationsfeld
                If blnInsert Then
                  If strColDefault <> "" Then
                    Response.Write("        <select size=""1"" name=""" & objField.Name & """>" & vbCrLf & _
                      "          <option value=""" & strColDefault & """ selected="""">" & objField.Value & "</option>" & vbCrLf &_
                      "          <option value=""" & (Not strColDefault) & """>" & (Not objField.Value) & "</option>" & vbCrLf &_
                      "        </select>" & vbCrLf)
                  Else
                    Response.Write("        <select size=""1"" name=""" & objField.Name & """>" & vbCrLf & _
                      "          <option value=""null"" selected=""""> </option>" & vbCrLf &_
                      "          <option value=""" & objField.Value & """>" & objField.Value & "</option>" & vbCrLf &_
                      "          <option value=""" & (Not objField.Value) & """>" & (Not objField.Value) & "</option>" & vbCrLf &_
                      "        </select>" & vbCrLf)
                  End If
                Else
                  Response.Write("        <select size=""1"" name=""" & objField.Name & """>" & vbCrLf & _
                    "          <option value=""" & objField.Value & """ selected="""">" & objField.Value & "</option>" & vbCrLf &_
                    "          <option value=""" & (Not objField.Value) & """>" & (Not objField.Value) & "</option>" & vbCrLf &_
                    "        </select>" & vbCrLf)
                End If
              Else
                If strColDataType = adWChar Then
                  If objField.DefinedSize > INTDEFAULTSIZE Then
                    intSize = INTDEFAULTSIZE
                  Else
                    intSize = objField.DefinedSize
                  End If
                  intMaxLength = objField.DefinedSize
                End If
                Response.Write("        <input type=""text"" size=""" & intSize & _
                  """ maxlength=""" & intMaxLength & """ name=""" & objField.Name & _
                  """ value=""" & objField.Value & """ />" & vbCrLf)
              End If
            End If 'funIntInArray(arrSpecialFields, objField.Name, 0) >= 0
          Else
            Response.Write("        " & objField.Value & " " & vbCrLf)
          End If
          Response.Write("      </td>" & vbCrLf)

          'Mitteilungen
          Response.Write("      <td>" & vbCrLf)
          If dicMeldungen.Exists(objField.Name) Then
            Response.Write("        " & dicMeldungen.Item(objField.Name) & vbCrLf)
          ElseIf Not strColIs_Nullable Then
            Response.Write("        Null nicht erlaubt" & vbCrLf)
          Else
            Response.Write(" " & vbCrLf)
          End If

          Response.Write("      </td>" & vbCrLf)
          Response.Write("    </tr>" & vbCrLf)
        Next
      End If
      Response.Write("  </table>" & vbCrLf)
      'Response.Write("PK: " & strPrimaryKeys & "<br /> <br />" & vbCrLf)

    End If 'objRS.State = adStateOpen
  End If 'IsObject(objRS)

  objrs.CancelUpdate
  objrs.Close
  Set objrs = Nothing
  Response.Write("   <br /><input type=""submit"" value=""Abschicken"" name=""btnSubmit"">" & vbCrLf & _
    "</form>" & vbCrLf)
End Sub

'Setzt WHERE-Clause für PKs zusammen
'Wert lässt sich mit Join(Split.. ersetzen
Function funStrPrimaryKeys(strcon, strTablename)
  Const adSchemaPrimaryKeys = 28
  Dim arrKeys(5)
  Dim blnFirst
  blnFirst = True
  Dim intCounter
  Dim objcon
  Dim objField
  Dim rsSchema
  Dim strHelp

  Set objcon = Server.CreateObject("ADODB.Connection")

  objcon.Open strcon

  Set rsSchema = objcon.OpenSchema(adSchemaPrimaryKeys)
  rsSchema.Filter = "TABLE_NAME = '" & strTablename & "'"
  Do Until rsSchema.EOF
    arrKeys(rsSchema("ORDINAL") - 1) = rsSchema("COLUMN_NAME")
    rsSchema.MoveNext
  Loop
  For intCounter = 0 To 4
    If arrKeys(intCounter) <> "" Then
      If blnFirst Then
        strHelp = " WHERE " & arrKeys(intCounter) & " = |" & arrKeys(intCounter) & "|"
        blnFirst = False
      Else
        strHelp = strHelp & " AND " & arrKeys(intCounter)  & " = |" & arrKeys(intCounter) & "|"
      End If
    End If
  Next

  funStrPrimaryKeys = strHelp
End Function

'**********************************************************************************************************
'Verarbeitet ein generisches Formular
'arrPKs: 2 Spalten, erste Spalte Feldname, 2. Spalte Wert
'arrSpecialFields: 3 Spalten, 1) Feldname 2) Was passiert (function, value, null oder noupdate)
'  3) Wert für function oder value
Sub procUpdateFromGenericForm(ByVal objcon, ByRef dicMeldungen) 'ByVal arrPKs, _
  'ByVal arrSpecialFields, , ByVal intBorder)

  Dim blnInsert
  Dim blnUpdateOK
  blnUpdateOK = true
  Dim objField
  Dim objRS
  Dim rsSchemaColumns
  Dim strColDataType
  Dim strSql

  strsql = Request("fldstrSQL")
  blnInsert = Request("fldblninsert")

  Set rsSchemaColumns = objcon.OpenSchema(adSchemaColumns)

  Set objRS = Server.CreateObject("ADODB.Recordset")
  objRS.Open strsql, objcon, 1, 3

  If blnInsert Then
    objrs.AddNew
  End If

  If IsObject(objRS) Then
    If objRS.State = adStateOpen Then
      If Not objRS.EOF Then
        '**************************************************************************
        For each objField In objRS.Fields
          'Überprüfen
          '- Datentyp
          If Request(objField.Name) <> "" Then
            strColDataType = funStrValueAusSchema(rsSchemaColumns, _
              "TABLE_NAME = '" & Request("fldstrtablename") & "' AND COLUMN_NAME = '" & objField.Name & "'", "DATA_TYPE", "")
            'Response.Write(objField.Name & " (" & strColDataType & "): " & Request(objField.Name) & "<br />" & vbCrLf)
            Select Case strColDataType
              Case adDate
                If IsDate(Request(objField.Name)) Then
                  objField.Value = Request(objField.Name)
                Else
                  'dicMeldungen zuweisen
                  dicMeldungen.Add objField.Name, "kein gültiges Datum"
                End If
              Case adSmallInt,adInteger, adSingle, adDouble, adCurrency, adDecimal, adUnsignedTinyInt, adNumeric
                If IsNumeric(Request(objField.Name)) Then
                  objField.Value = Request(objField.Name)
                Else
                  'dicMeldungen zuweisen
                  dicMeldungen.Add objField.Name, "keine gültige Zahl"
                End If
              Case adBoolean
                If Request(objField.Name) = True Then
                  objField.Value = True
                ElseIf Request(objField.Name) = False Then
                  objField.Value = False
                Else
                  dicMeldungen.Add objField.Name, "kein gültiger boolscher Wert (Wahr/Falsch)"
                End If
              Case Else
                objField.Value = Request(objField.Name)
            End Select
          End If
        Next
        objRS.Update
      End If 'Not objRS.EOF
    End If 'objRS.State = adStateOpen
  End If 'IsObject(objRS)
End Sub

'**********************************************************************************************************
'Aufruf Formularverarbeitung
If Request.Form <> "" Then
  call procUpdateFromGenericForm(objcon, dicMeldungen)
End If
'*****************************************************************
'Anfang <html>
%>

<html>
  <head>
    <title>ASP Datenbankanbindung: Generisches Formular für beliebige Tabellen</title>

  </head>
<body>
<h3>ASP Datenbankanbindung: Generisches Formular für beliebige Tabellen</h3>
<p>Beispiel einer Access-DB</p>
<%
'*****************************************************************
'Code innerhalb der HTML-Seite

call procGenericForm(false, objcon, strTableName, arrPKs, arrSpecialFields, dicMeldungen, 1)
%>

</body>
</html>
Demo: beispiele/060dbGenericForm.asp

Letzter Update: 26.12.2021 17:48

Zurück zur Liste mit ASP-Beispielen auf www.ecotronics.ch