Option Explicit
'------------------------------------------------------------------------------
' ---------
' Procedure : SetValueToDB
' DateTime  : 25.10.2007 18:08
' Author    : jan2003
' Purpose   : schreiben EINES Wertes in die Datenbank
' Parameter : psField - Angabe des Feldes
'             psValue - zu schreibender Wert
'             psTabelle - Angabe der Tabelle/Abfrage
'             psDatabase - Optional Name und Pfad der DB
'             psCriteria - Optional DS-Einschränkung
' Response  : True ...  Datenfeld gefunden
'             False ... KEIN Datenfeld gefunden
'------------------------------------------------------------------------------
' ---------
'
Public Function SetValueToDB( _
       psField As String, _
       psValue As Variant, _
       psTabelle As String, _
       Optional psDatabase _
       As String = vbNullString, _
       Optional psCriteria _
       As String = vbNullString) As Boolean
 
    On Error GoTo HandleErr
 
    ' Verweis auf ActiveX Data Object 2.X muss gesetzt sein!
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
 
    Dim sSQL As String
    Dim sErrMsg As String
 
    ' SQL-String zusammen schnipseln
    sSQL = "SELECT  " & psField & " FROM " & psTabelle
    ' Falls Kriterium angegeben, WHERE-Klausel erstellen
    If Len(psCriteria) > 0 Then
        sSQL = sSQL & " WHERE " & psCriteria
    End If
    sSQL = sSQL & ";"
 
    ' Datenbank öffnen
    If Len(psDatabase) > 0 Then
        Set cnn = New ADODB.Connection
        cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                 "Data Source=" & psDatabase
        'cnn.Mode = adModeReadWrite
        '
        'für VB6 deaktiviert - Jan Tappenbeck, 2007-10-24
        'Else
        '    Set cnn = CurrentProject.Connection
    End If
 
    ' Recordset öffnen
    Set rst = New ADODB.Recordset
 
    rst.Open sSQL, cnn, adOpenStatic
    rst.LockType = adLockOptimistic
    rst.CursorLocation = adUseServer
 
    ' Falls DS vorhanden, ersten Wert übergeben
    If rst.RecordCount > 0 Then
        rst.Fields(psField) = psValue
       rst.Update
        SetValueToDB = True
    Else
        SetValueToDB = False
    End If
 
HandleExit:
    On Error Resume Next
    If Not rst Is Nothing Then rst.Close: Set rst = Nothing
    If Not cnn Is Nothing Then cnn.Close: Set cnn = Nothing
    Exit Function
 
HandleErr:
 
sErrMsg = "Fehler beim Schreiben eines Tabellenwertes ! -" & _
  "clsProfilDB#SetValueToDB " & Err.Description & " " & Err.Number
 
    Select Case Err.Number
    Case Else
        Call MsgBox(sErrMsg)
        Debug.Print sErrMsg
    End Select
    SetValueToDB = False
    Resume HandleExit
 
 
End Function

Visual Basic 6.0 Grundkenntnisse und ansonsten alles rund um AutoCAD