laatzen/Pruef2000/source/Shared/universal/Recordset.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CRecordset"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'==============================================================================
'
' File   : Recordset.cls
' Date   : 22.03.1999
' Version: 1.02
' Author : Andreas Schmidt, lindner&partner
'
'==============================================================================
'
' *shared*
'
' Abstraktion von ADODB.Recordset
'
'==============================================================================
'
' History:
'
' Date   : 22.03.1999
' Version: 1.02
' Author : Andreas Schmidt, lindner&partner
'
' Fehlerbehandlung in 'isFieldNull' neu.
'
' Date   : 22.03.1999
' Version: 1.01
' Author : Andreas Schmidt, lindner&partner
'
' Methoden isFieldNull und getSingleValue neu.
'
' Date   : 12.02.1999
' Version: 1.00
' Author : Andreas Schmidt, lindner&partner
'
' Erste Version.
'
'==============================================================================

Option Explicit

' Private Member
' --------------
Dim m_connection As ADODB.connection
Dim m_rs As ADODB.Recordset
Dim connectionInitialize As Boolean


' Connection der Standarddatenbank übernehmen
'
Private Sub Class_Initialize()
   
   
   If Not g_App Is Nothing Then
      Set m_connection = g_App.getDB().getConnection()
      connectionInitialize = True
   End If
   
End Sub


'------------------------------------------------------------------------------
' Öffentliche Funktionalität
'------------------------------------------------------------------------------

' @param DB Referenz auf eine CDBAccess
'
Public Sub setDB(db As CDBAccess)
    Set m_connection = db.getConnection()
    connectionInitialize = True
End Sub

' @param connection Referenz auf eine ADODB.Connection
'
Public Sub setConnection(connection As ADODB.connection)
    Set m_connection = connection
End Sub

' Recordset eröffnen
'
' @param sSQL   SQL-String
' @param bRO    true = read-only eröffnen
'
' @return   true  = Recordset eröffnet,
'           false = Fehler bei der Eröffnung
'
Public Function openRS(ByVal sSQL As String, Optional bRO As Boolean) As Boolean
 Dim lngFehlerzaehler As Long
 Dim lngErrornumber As Long
 Dim strErrordesc As String
 
    Set m_rs = New ADODB.Recordset
    
    On Error GoTo openRSErr
    
    If Not connectionInitialize Then Class_Initialize
    
    If bRO Then
        m_rs.Open sSQL, getConnection(), adOpenStatic, adLockReadOnly
    Else
        'Open dauert 8 Sekunden
        'm_rs.Open sSQL, getConnection(), adOpenKeyset, adLockPessimistic
        m_rs.Open sSQL, getConnection(), adOpenKeyset, adLockOptimistic
    End If
        
    'Die Anweisung RecordCount dauer ca. 120 sek
    ' If (m_rs.RecordCount > 0) Then m_rs.MoveFirst
    
    ' DebugMsg "SQL=" & sSQL & "     (" & m_rs.RecordCount & ")"
    
    openRS = True
    Exit Function
    
openRSErr:
    lngErrornumber = Err.Number
    strErrordesc = Err.Description
    
    Select Case lngErrornumber
       ' Bei diesem Fehler ist eine Wiederholung zwecklos
       ' -2147217900: Ungültiger Spaltenname, Die gespeicherte Prozedur '' wurde nicht gefunden, Falsche Syntax
       Case -2147217900, -2147217865
          ErrorMsg "SQL Syntax Fehler: Bitte Programmierer benachrichtigen! " & vbCrLf & strErrordesc & vbCrLf & sSQL
          openRS = False
          Exit Function
    End Select
        
      lngFehlerzaehler = lngFehlerzaehler + 1
      ' zehn mal Reconnect versuchen
      If lngFehlerzaehler < 10 Then
        Sleep 1000, False
        Call Reconnect
        Resume
      End If
    
Fehler_ende:
   ErrorMsg ("CRecordset.openRS: Fehler " & lngErrornumber & ": " & strErrordesc & "(" & lngFehlerzaehler & " mal versucht)")
   openRS = False
   Err.Raise lngErrornumber, , strErrordesc
   
   Exit Function
    Resume
End Function

' @return Anzahl der Sätze im Recordset
'
Public Function RecordCount() As Long
    RecordCount = m_rs.RecordCount()
End Function

' Aktuellen Satz aus dem RecordSet löschen
'
Public Function delete() As Boolean
    m_rs.delete
End Function

' @return true = EOF
'
Public Property Get EOF() As Boolean
    EOF = (m_rs.EOF)
End Property

' @return true = BOF
'
Public Property Get BOF() As Boolean
    BOF = (m_rs.BOF)
End Property

Public Property Get FieldsCount() As Long
    FieldsCount = m_rs.Fields.Count
End Property

Public Property Get FieldName(Index As Long) As String
    FieldName = m_rs.Fields(Index).Name
End Property

Public Sub MoveFirst()
    m_rs.MoveFirst
End Sub

Public Sub MoveLast()
    m_rs.MoveLast
End Sub

Public Sub MoveNext()
    If Not m_rs.EOF Then m_rs.MoveNext
End Sub

Public Sub MovePrevious()
    If Not m_rs.BOF Then m_rs.MovePrevious
End Sub

Public Function addNew() As Boolean
    m_rs.addNew
    addNew = True
End Function

Public Function update() As Boolean
Dim lngFehlerzaehler As Long
Dim strText As String
Dim Field As ADODB.Field

On Error GoTo UpdateError
    
    If m_rs.State <> adStateOpen Then
        WriteToLog "CRecodrset.update m_rs.State = " & m_rs.State & " <> adStateOpen "
    End If

    m_rs.update
    update = True
    
    If lngFehlerzaehler > 0 Then
        WriteToLog strText & vbCrLf & lngFehlerzaehler & " mal versucht."
    End If
    Exit Function
    
UpdateError:
            
    strText = "Fehler " & Err.Number & " in CRecordset.Update(): " & Err.Description & vbCrLf
    ' 10 mal versuchen
    lngFehlerzaehler = lngFehlerzaehler + 1
    If lngFehlerzaehler < 10 Then
        Call Reconnect
        Resume
    End If
    
    strText = "10 mal Fehler " & Err.Number & " in CRecordset.Update(): " & vbCrLf & Err.Description & vbCrLf
    strText = strText & m_rs.Source & vbCrLf
    For Each Field In m_rs.Fields
        strText = strText & Field.Name & "=" & Field.value & ","
    Next
    
    strText = strText & vbCrLf & "Es liegt möglicherweise eine Störung der Datenbank vor."
    ErrorMsg strText
    
    update = False
End Function

' String zur Verwendung in einem SQL-Statement umwandeln
'
' @param s      String, der in ein SQL-Statement gesetzt werden soll
' @param bTicks true = String soll von einfachen Hochkommans umschlossen werden
'
Public Function stringToSQLString(ByVal s As String, Optional bTicks As Boolean) As String
    stringToSQLString = modSQL.stringToSQLString(s, bTicks)
End Function

' @param sDateTime  Datum, das in ein SQL-Statement gesetzt werden soll
'
Public Function dateToSQLString(ByVal sDateTime As String) As String
    dateToSQLString = modSQL.stringToSQLString(sDateTime)
End Function

' @return true = Das angegebene Feld ist null
'
Public Function isFieldNull(sField As String) As Boolean
    On Error GoTo isFieldNullErr
    isFieldNull = IsNull(m_rs(sField))
    Exit Function
    
isFieldNullErr:
    Call showError("isFieldNull")
    Exit Function
End Function

' Feld als String zurückgeben
'
' @param sField Name des Feldes, das zurückgegeben werden soll
' @return Inhalt des Datenbankfeldes als String-Wert
'
Public Function getStringValue(sField As String) As String
    On Error GoTo getStringValueErr
    
    If IsNull(m_rs(sField)) Then
        getStringValue = ""
    Else
        getStringValue = RTrim$(CStr(m_rs(sField)))
    End If
    Exit Function
    
getStringValueErr:
    Call showError(".getStringValue(" & sField & ")")
    Exit Function
End Function

' Feld als Integer zurückgeben
'
' @param sField Name des Feldes, das zurückgegeben werden soll
' @return Inhalt des Datenbankfeldes als Integer-Wert
'
Public Function getIntValue(sField As String) As Long
    On Error GoTo getIntValueErr
    
    If IsNull(m_rs(sField)) Then
        getIntValue = 0
    Else
        getIntValue = CInt(m_rs(sField))
    End If
    Exit Function
    
getIntValueErr:
    Call showError("getIntValue(" & sField & ")")
    Exit Function
    
End Function

' Feld als Single zurückgeben
'
' @param sField Name des Feldes, das zurückgegeben werden soll
' @return Inhalt des Datenbankfeldes als Integer-Wert
'
Public Function getSingleValue(sField As String) As Single
    On Error GoTo getSingleValueErr
    
    If IsNull(m_rs(sField)) Then
        getSingleValue = 0
    Else
        getSingleValue = CSng(m_rs(sField))
    End If
    Exit Function
    
getSingleValueErr:
    Call showError("getSingleValue(" & sField & ")")
    Exit Function
    
End Function

' Feld als Byte zurückgeben
'
' @param sField Name des Feldes, das zurückgegeben werden soll
' @return Inhalt des Datenbankfeldes als Byte-Wert
'
Public Function getByteValue(sField As String) As Byte
    On Error GoTo getByteValueErr
    
    If IsNull(m_rs(sField)) Then
        getByteValue = 0
    Else
        getByteValue = CByte(m_rs(sField))
    End If
    Exit Function
    
getByteValueErr:
    Call showError("getByteValue(" & sField & ")")
    Exit Function
    
End Function

' Feld als Long zurückgeben
'
' @param sField Name des Feldes, das zurückgegeben werden soll
' @return Inhalt des Datenbankfeldes als Long-Wert
'
Public Function getLongValue(sField As String) As Long
    On Error GoTo getLongValueErr
    
    If IsNull(m_rs(sField)) Then
        getLongValue = 0&
    Else
        getLongValue = CLng(m_rs(sField))
    End If
    Exit Function
    
getLongValueErr:
    Call showError("getLongValue(" & sField & ")")
    Exit Function
End Function

' Feld als Date zurückgeben
'
' @param sField Name des Feldes, das zurückgegeben werden soll
' @return Inhalt des Datenbankfeldes als Date-Wert
'
Public Function getDateValue(sField As String) As Date
    On Error GoTo getDateValueErr
    
    If IsNull(m_rs(sField)) Then
        getDateValue = 0
    Else
        getDateValue = CDate(m_rs(sField))
    End If
    Exit Function
    
getDateValueErr:
    getDateValue = 0
    'Call showError("getDateValue(" & sField & ")")
    Exit Function
End Function

' Feld als Double zurückgeben
'
' @param sField Name des Feldes, das zurückgegeben werden soll
' @return Inhalt des Datenbankfeldes als Double-Wert
'
Public Function getDoubleValue(sField As String) As Double
    On Error GoTo getDoubleValueErr
    
    If IsNull(m_rs(sField)) Then
        getDoubleValue = 0
    Else
        getDoubleValue = CDbl(m_rs(sField))
    End If
    Exit Function
    
getDoubleValueErr:
    Call showError("getDoubleValue(" & sField & ")")
    Exit Function
    
End Function

' Feld als Boolean zurückgeben
'
' @param sField Name des Feldes, das zurückgegeben werden soll
' @return Inhalt des Datenbankfeldes als Boolean-Wert
'
Public Function getBooleanValue(sField As String) As Boolean
    On Error GoTo getBooleanValueErr
    
    If IsNull(m_rs(sField)) Then
        getBooleanValue = False
    Else
        getBooleanValue = m_rs(sField)
    End If
    Exit Function
    
getBooleanValueErr:
    Call showError("getBooleanValue(" & sField & ")")
    Exit Function
    
End Function

' Feld schreiben
'
' @param sField Name des Feldes
' @param vData  zu schreibender Feldwert
'
' @return true = Feld wurde aktualisiert, false = Fehler
'
Public Function setValue(sField As String, vData As Variant) As Boolean
    On Error GoTo setValueErr
    
    Debug.Print sField & "=" & vData & " (" & m_rs(sField) & ")"
    
    m_rs(sField) = vData
    setValue = True
    Exit Function
    
setValueErr:
    Call showError("setValue (Feld '" + sField + "', Data: '" & vData & "')")
    Exit Function
    
End Function


'------------------------------------------------------------------------------
' Private Funktionalität
'------------------------------------------------------------------------------

' @return Referenz auf die zu verwendene ADODB.connection
'
Private Function getConnection() As ADODB.connection
    Set getConnection = m_connection
End Function


' Helper für Fehlerausgaben
'
' @param sMethod    Name der aufrufenden Methode
' @param sInfo      optionaler Hinweistext
'
Private Sub showError(sMethod As String, Optional sInfo As String)
    Call modError.showError("CRecordset." + sMethod, sInfo)
End Sub

Public Function GetRecordsetObject() As ADODB.Recordset
    Set GetRecordsetObject = m_rs
End Function

Private Sub Reconnect_alt()
    Dim strConnectionString As String
    strConnectionString = m_connection.ConnectionString
    Set m_connection = New ADODB.connection
        
    m_connection.Open strConnectionString
    LogIntoDB "Reconnected erfolgreich nach Datenbank Verbindungsfehler", "Datenbank"

End Sub

Private Function Reconnect() As Boolean
    Dim strConnectionString As String
    On Error GoTo Errorhandler
    
    ' Datenbank Verbindungstring merken
    'strConnectionString = m_connection.ConnectionString
    
    strConnectionString = g_App.Settings.ADOConnectionstring
    
    ' Verbindung schließen
    g_App.getDB.CloseConnection
    ' Verbindung der Applikation zur Datenbank erneut herstellen
    g_App.getDB.ADOConnect (strConnectionString & ";Uid=PrgPruefstation;Password=PrgPruefstation")
    
    ' auch fpr dieses Recodset verwenden
    Set m_connection = g_App.getDB.getConnection
    Reconnect = True
    LogIntoDB "Funktion 'Reconnect' erfolgreich nach Datenbank Verbindungsfehler", "Datenbank"
    Exit Function
Errorhandler:
    Reconnect = False
End Function

Public Function GetCurrencyValue(sField As String) As Currency
    GetCurrencyValue = m_rs(sField).value
End Function


Public Function GetVariantValue(sField As String) As Variant
    GetVariantValue = m_rs(sField).value
End Function

Public Function UpdateBatch(AffectedRecords As AffectEnum) As Boolean
    m_rs.UpdateBatch AffectedRecords
End Function