<%@ 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>
%>
<!--#include virtual="asppages/silvi/_include/preheader.inc" -->
<html>
<head>
<title>ASP Datenbankanbindung: Generisches Formular für beliebige Tabellen
</title>
<!--#include virtual="asppages/silvi/_include/header.inc" -->
</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)
%>
<!--#include virtual="asppages/silvi/_include/inchtmlnachspann.asp" -->
</body>
</html>
Demo: beispiele/060dbGenericForm.asp
Letzter Update:
26.12.2021 16:48
Zurück zur
Liste mit ASP-Beispielen auf
www.ecotronics.ch