rothen ecotronics Bern: ASP-Skript "ASP Datenbankanbindung: Technische Information zu Tabellen und Feldern auslesen"

<%@ 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 blnerstezeile, objcon, objrs, objfield
Dim objProperty
Dim strcon, strsql
Dim strFieldAttributes
Dim strPrimaryKeys

blnerstezeile = true

'Recordset geöffnet?
Const adStateOpen = &H00000001

'Schema
Const adSchemaProviderSpecific = -1
Const adSchemaAsserts = 0
Const adSchemaCatalogs = 1
Const adSchemaCharacterSets = 2
Const adSchemaCollations = 3
Const adSchemaColumns = 4
Const adSchemaCheckConstraints = 5
Const adSchemaConstraintColumnUsage = 6
Const adSchemaConstraintTableUsage = 7
Const adSchemaKeyColumnUsage = 8
Const adSchemaReferentialContraints = 9
Const adSchemaTableConstraints = 10
Const adSchemaColumnsDomainUsage = 11
Const adSchemaIndexes = 12
Const adSchemaColumnPrivileges = 13
Const adSchemaTablePrivileges = 14
Const adSchemaUsagePrivileges = 15
Const adSchemaProcedures = 16
Const adSchemaSchemata = 17
Const adSchemaSQLLanguages = 18
Const adSchemaStatistics = 19
Const adSchemaTables = 20
Const adSchemaTranslations = 21
Const adSchemaProviderTypes = 22
Const adSchemaViews = 23
Const adSchemaViewColumnUsage = 24
Const adSchemaViewTableUsage = 25
Const adSchemaProcedureParameters = 26
Const adSchemaForeignKeys = 27
Const adSchemaPrimaryKeys = 28
Const adSchemaProcedureColumns = 29

'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

'*****************************************************************

'weist einer Schema-Konstanten einen Namen zu
Function funSchemaName(ByVal intSchema)
   Select Case intSchema
   Case adSchemaProviderSpecific
      funSchemaName = "adSchemaProviderSpecific"
   Case adSchemaAsserts
      funSchemaName = "adSchemaAsserts"
   Case adSchemaCatalogs
      funSchemaName = "adSchemaCatalogs"
   Case adSchemaCharacterSets
      funSchemaName = "adSchemaCharacterSets"
   Case adSchemaCollations
      funSchemaName = "adSchemaCollations"
   Case adSchemaColumns
      funSchemaName = "adSchemaColumns"
   Case adSchemaCheckConstraints
      funSchemaName = "adSchemaCheckConstraints"
   Case adSchemaConstraintColumnUsage
      funSchemaName = "adSchemaConstraintColumnUsage"
   Case adSchemaConstraintTableUsage
      funSchemaName = "adSchemaConstraintTableUsage"
   Case adSchemaKeyColumnUsage
      funSchemaName = "adSchemaKeyColumnUsage"
   Case adSchemaReferentialContraints
      funSchemaName = "adSchemaReferentialContraints"
   Case adSchemaTableConstraints
      funSchemaName = "adSchemaTableConstraints"
   Case adSchemaColumnsDomainUsage
      funSchemaName = "adSchemaColumnsDomainUsage"
   Case adSchemaIndexes
      funSchemaName = "adSchemaIndexes"
   Case adSchemaColumnPrivileges
      funSchemaName = "adSchemaColumnPrivileges"
   Case adSchemaTablePrivileges
      funSchemaName = "adSchemaTablePrivileges"
   Case adSchemaUsagePrivileges
      funSchemaName = "adSchemaUsagePrivileges"
   Case adSchemaProcedures
      funSchemaName = "adSchemaProcedures"
   Case adSchemaSchemata
      funSchemaName = "adSchemaSchemata"
   Case adSchemaSQLLanguages
      funSchemaName = "adSchemaSQLLanguages"
   Case adSchemaStatistics
      funSchemaName = "adSchemaStatistics"
   Case adSchemaTables
      funSchemaName = "adSchemaTables"
   Case adSchemaTranslations
      funSchemaName = "adSchemaTranslations"
   Case adSchemaProviderTypes
      funSchemaName = "adSchemaProviderTypes"
   Case adSchemaViews
      funSchemaName = "adSchemaViews"
   Case adSchemaViewColumnUsage
      funSchemaName = "adSchemaViewColumnUsage"
   Case adSchemaViewTableUsage
      funSchemaName = "adSchemaViewTableUsage"
   Case adSchemaProcedureParameters
      funSchemaName = "adSchemaProcedureParameters"
   Case adSchemaForeignKeys
      funSchemaName = "adSchemaForeignKeys"
   Case adSchemaPrimaryKeys
      funSchemaName = "adSchemaPrimaryKeys"
   Case adSchemaProcedureColumns
      funSchemaName = "adSchemaProcedureColumns"
   Case Else
      funSchemaName = "unbekannt"
   End Select
End Function

'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

'Zeigt für die verschiedenen Schema-Konstanten Tabellen an
Sub procSchemaToTable(strcon, intSchema)
  Dim objcon
  Dim objfield
  Dim rsSchema

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

  Response.Write intSchema
  objcon.Open strcon

  on error resume next
  Set rsSchema = objcon.OpenSchema(intSchema)

  If err.number = 3251 Then
    response.flush
    response.write " <b>" & funSchemaName(intSchema)
    response.write "</b><br /> is not supported<br />"
    err.clear
  Else
    response.write " <b>" & funSchemaName(intSchema) & "</b><br />"
    response.write "<table border=""1""><tr>"

    'Beschriftungen
    For each objfield in rsSchema.fields
     response.write "<td><b>" & objfield.name & "</b></td>"
    next
    response.write "</tr>"

    'Felder
    Do Until rsSchema.EOF
      'Systemtabellen ausgenommen
      If Left(rsSchema("TABLE_NAME"), 4) <> "MSys" Then
        response.write "<tr>"
        for each objField in rsSchema.fields
          response.write "<td valign=""top"">" & Trim(objField.value) & " </td>"
        next
        response.write "</tr>"
      End If
      rsSchema.MoveNext
    Loop
    response.write "</table><br />"
    response.flush
  End If

  rsSchema.Close
  set rsSchema = nothing

  objcon.close
  set objcon = nothing
End Sub

'*****************************************************************
'Anfang <html>
%>

<html>
  <head>
    <title>ASP Datenbankanbindung: Technische Information zu Tabellen und Feldern auslesen</title>

  </head>
<body>
<h3>ASP Datenbankanbindung: Technische Information zu Tabellen und Feldern auslesen</h3>
<p>Beispiel einer Access-DB</p>
<%
'*****************************************************************
'Code innerhalb der HTML-Seite

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

'Schema auslesen
Dim objSchema

'Tabellen
call procSchemaToTable(strcon, adSchemaTables)

'Tabellenspalten
call procSchemaToTable(strcon, adSchemaColumns)

'Primärschlüssel
call procSchemaToTable(strcon, adSchemaPrimaryKeys)

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

'Select
strsql = "SELECT * FROM tblfieldtest"
Set objrs = Server.CreateObject("ADODB.Recordset")
objrs.Open strsql, objcon, 1, 3

Response.Write("<b>Recordset-Properties</b><br />" & vbCrLf)
Response.Write("<table border=""1"">" & vbCrLf)
For Each objProperty In objrs.Properties
  Response.Write("  <tr>" & vbCrLf)
  Response.Write("    <td>" & objProperty.Name & " </td><td>" & objProperty.Value & " </td>" & vbCrLf)
  Response.Write("  </tr>" & vbCrLf)
Next
Response.Write("</table>" & vbCrLf)
Response.Write(" <br />" & vbCrLf)

If IsObject(objRS) Then
  If objRS.State = adStateOpen Then
    Response.Write("<table border=""1"">" & vbCrLf)
    If Not objRS.EOF Then
      If blnerstezeile Then
        Response.Write("<tr>" & vbCrLf)

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

        'Feldtyp
        Response.Write("<td valign=""top"">" & vbCrLf)
        Response.Write("<b>Feldtyp</b>" & vbCrLf)
        Response.Write("</td>" & vbCrLf)

        'Grösse, NumericScale, Precision
        Response.Write("<td valign=""top"">" & vbCrLf)
        Response.Write("<b>Grösse<br />Numeric Scale<br />Precision</b>" & vbCrLf)
        Response.Write("</td>" & vbCrLf)

        'Feldattribute
        Response.Write("<td valign=""top"">" & vbCrLf)
        Response.Write("<b>Feldattribute</b>" & vbCrLf)
        Response.Write("</td>" & vbCrLf)

        'Eingabe- oder Anzeigefelder
        Response.Write("<td valign=""top"">" & vbCrLf)
        Response.Write("<b>Eingabefeld</b>" & vbCrLf)
        Response.Write("</td>" & vbCrLf)

        Response.Write("</tr>" & vbCrLf)
        blnerstezeile = False
      End If
      For each objField In objRS.Fields
        Response.Write("<tr>" & vbCrLf)

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

        'Feldtyp
        Response.Write("<td valign=""top"">" & vbCrLf)
        Select Case objField.Type
          Case adEmpty
            Response.Write(objField.Type & " adEmpty" & vbCrLf)
          Case adSmallInt
            Response.Write(objField.Type & " adSmallInt" & vbCrLf)
          Case adInteger
            Response.Write(objField.Type & " adInteger" & vbCrLf)
          Case adSingle
            Response.Write(objField.Type & " adSingle" & vbCrLf)
          Case adDouble
            Response.Write(objField.Type & " adDouble" & vbCrLf)
          Case adCurrency
            Response.Write(objField.Type & " adCurrency" & vbCrLf)
          Case adDate
            Response.Write(objField.Type & " adDate" & vbCrLf)
          Case adBSTR
            Response.Write(objField.Type & " adBSTR" & vbCrLf)
          Case adIDispatch
            Response.Write(objField.Type & " adIDispatch" & vbCrLf)
          Case adError
            Response.Write(objField.Type & " adError" & vbCrLf)
          Case adBoolean
            Response.Write(objField.Type & " adBoolean" & vbCrLf)
          Case adVariant
            Response.Write(objField.Type & " adVariant" & vbCrLf)
          Case adIUnknown
            Response.Write(objField.Type & " adIUnknown" & vbCrLf)
          Case adDecimal
            Response.Write(objField.Type & " adDecimal" & vbCrLf)
          Case adTinyInt
            Response.Write(objField.Type & " adTinyInt" & vbCrLf)
          Case adUnsignedTinyInt
            Response.Write(objField.Type & " adUnsignedTinyInt" & vbCrLf)
          Case adUnsignedSmallInt
            Response.Write(objField.Type & " adUnsignedSmallInt" & vbCrLf)
          Case adUnsignedInt
            Response.Write(objField.Type & " adUnsignedInt" & vbCrLf)
          Case adBigInt
            Response.Write(objField.Type & " adBigInt" & vbCrLf)
          Case adUnsignedBigInt
            Response.Write(objField.Type & " adUnsignedBigInt" & vbCrLf)
          Case adGUID
            Response.Write(objField.Type & " adGUID" & vbCrLf)
          Case adBinary
            Response.Write(objField.Type & " adBinary" & vbCrLf)
          Case adChar
            Response.Write(objField.Type & " adChar" & vbCrLf)
          Case adWChar
            Response.Write(objField.Type & " adWChar" & vbCrLf)
          Case adNumeric
            Response.Write(objField.Type & " adNumeric" & vbCrLf)
          Case adUserDefined
            Response.Write(objField.Type & " adUserDefined" & vbCrLf)
          Case adDBDate
            Response.Write(objField.Type & " adDBDate" & vbCrLf)
          Case adDBTime
            Response.Write(objField.Type & " adDBTime" & vbCrLf)
          Case adDBTimeStamp
            Response.Write(objField.Type & " adDBTimeStamp" & vbCrLf)
          Case adVarChar
            Response.Write(objField.Type & " adVarChar" & vbCrLf)
          Case adLongVarChar
            Response.Write(objField.Type & " adLongVarChar" & vbCrLf)
          Case adVarWChar
            Response.Write(objField.Type & " adVarWChar" & vbCrLf)
          Case adLongVarWChar
            Response.Write(objField.Type & " adLongVarWChar" & vbCrLf)
          Case adVarBinary
            Response.Write(objField.Type & " adVarBinary" & vbCrLf)
          Case adLongVarBinary
            Response.Write(objField.Type & " adLongVarBinary" & vbCrLf)
          Case Else
            Response.Write(objField.Type & " nicht bestimmbar " & vbCrLf)
        End Select
        Response.Write("</td>" & vbCrLf)

        'Grösse, NumericScale, Precision
        Response.Write("<td valign=""top"">" & vbCrLf)
        Response.Write(objField.DefinedSize & "<br />" & objField.NumericScale & _
          "<br />" & objField.Precision & vbCrLf)
        Response.Write("</td>" & vbCrLf)

        'Feldattribute
        strFieldAttributes = ""
        Response.Write("<td valign=""top"">" & vbCrLf)
        If CBool(objField.Attributes And adFldMayDefer) Then
          strFieldAttributes = strFieldAttributes & " adFldMayDefer<br />"
        End If
        If CBool(objField.Attributes And adFldUpdatable ) Then
          strFieldAttributes = strFieldAttributes & " adFldUpdatable<br />"
        End If
        If CBool(objField.Attributes And adFldUnknownUpdatable ) Then
          strFieldAttributes = strFieldAttributes & " adFldUnknownUpdatable<br />"
        End If
        If CBool(objField.Attributes And adFldFixed ) Then
          strFieldAttributes = strFieldAttributes & " adFldFixed<br />"
        End If
        If CBool(objField.Attributes And adFldIsNullable ) Then
          strFieldAttributes = strFieldAttributes & " adFldIsNullable<br />"
        End If
        If CBool(objField.Attributes And adFldMayBeNull ) Then
          strFieldAttributes = strFieldAttributes & " adFldMayBeNull<br />"
        End If
        If CBool(objField.Attributes And adFldLong ) Then
          strFieldAttributes = strFieldAttributes & " adFldLong<br />"
        End If
        If CBool(objField.Attributes And adFldRowID ) Then
          strFieldAttributes = strFieldAttributes & " adFldRowID<br />"
        End If
        If CBool(objField.Attributes And adFldRowVersion ) Then
          strFieldAttributes = strFieldAttributes & " adFldRowVersion<br />"
        End If

        If Len(strFieldAttributes) > 2 Then
          strFieldAttributes = Left(strFieldAttributes, Len(strFieldAttributes) - 6)
          Response.Write(objField.Attributes & "<br />" & strFieldAttributes & vbCrLf)
        End If
        Response.Write(" <br /><b>Field-Properties</b><br />" & vbCrLf)
        For Each objProperty In objField.Properties
          Response.Write(objProperty.Name & " = " & objProperty.Value & "<br />" & vbCrLf)
        Next
        Response.Write(" <br />" & vbCrLf)

        Response.Write(" </td>" & vbCrLf)

        'Eingabe- oder Anzeigefelder
        Response.Write("<td valign=""top"">" & vbCrLf)
        If CBool(objField.Attributes And adFldUpdatable) Then
          If objField.Name <> "Erstellungsdatum" And objField.Name <> "Mutationsdatum" Then
            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
              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)
            Else
              Response.Write("<input type=""text"" size=""40"" name=""" & objField.Name & _
                """ value=""" & objField.Value & """ />" & vbCrLf)
            End If
          Else
            Response.Write(objField.Value & " " & vbCrLf)
          End If
        Else
          Response.Write(objField.Value & " " & vbCrLf)
        End If
        Response.Write("</td>" & vbCrLf)
      Response.Write("</tr>" & vbCrLf)
      Next
      objRS.MoveNext
    End If
    Response.Write("</table>" & vbCrLf)
  End If 'objRS.State = adStateOpen
End If 'IsObject(objRS)

objrs.Close
Set objrs = Nothing
%>

</body>
</html>

Demo: beispiele/060dbohneodbcfieldattributes.asp

Letzter Update: 26.12.2021 16:48

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