Function DB_anbinden() As Boolean
On Error GoTo err
Dim conn As String
    Set cn = New ADODB.Connection
 
    If cn.state = adStateClosed Then
        conn = " UID= Test;PWD=" & "read" & ";dsn=" & "Test"
        With cn
            .ConnectionString = conn
            .CursorLocation = adUseClient
            .ConnectionTimeout = 5
            .CommandTimeout = 10
            .Open
        End With
 
        If cn.state = adStateOpen Then
            DB_anbinden = True
        Else
            DB_anbinden = False
        End If
 
    End If
 
Exit Function
err:
cn.Close
MsgBox err.Description, vbCritical, "Fehler beim Verbindungsaufbau .."
 
End Function
 
Sub cmd_DatenLesen_Click()
    If DB_anbinden = True Then
        daten_lesen (strFilter)
    End If
End Sub
 
 
Sub daten_lesen(strFilter As String)
Dim strSQL As String
Dim oError As ADODB.Error
 
 
 
    Select Case Me.Tag
        Case g_strAuswertungstyp(0):
            strSQL = "SELECT s.schicht_pnr, p.Vorname, p.Nachname, p.ZULAGE," & _
              "p.MW_STAMMKST, p.MW_ALLEKST, p.GRUNDLOHN," _
                & " p.VERR_FAKTOR , p.LOHNKORREKTUr, p.Praemienberechtigt," & _
                "p.beeinfl_Praemien" _
                & " FROM schichtbeleg s inner join personalstamm p on" & _
                "s.schicht_pnr = p.pnr" _
                & strFilter _
                & " group by s.schicht_pnr, s.kst"
 
        Case g_strAuswertungstyp(1):
            strSQL = "SELECT s.schicht_pnr, p.Vorname, p.Nachname, p.ZULAGE," & _
              "p.MW_STAMMKST" _
                & " FROM schichtbeleg s inner join personalstamm p on" & _
                "s.schicht_pnr = p.pnr" _
                & strFilter _
                & " group by s.schicht_pnr"
 
        Case g_strAuswertungstyp(2):
 
    End Select
 
    Set rsPd = New ADODB.Recordset
    rsPd.CursorLocation = adUseClient
    rsPd.CursorType = adOpenKeyset
    rsPd.LockType = adLockReadOnly
 
    On Error Resume Next
    rsPd.Open strSQL, cn, , , adCmdText
    If g_Cn.Errors.Count > 0 Then
  ' alle ADO-Fehler des Connection-Objektes durchlaufen
    Dim sError As String ', sserror As String
    Dim ErrorText() As String
    Dim ErrorTextDet() As String
        For Each oError In cn.Errors
            ErrorText = Split(oError.Description, "]")
            ErrorTextDet = Split(ErrorText(3), ";")
 
            sError = sError & "Fehlernummer: " & CStr(oError.Number) & vbCrLf & _
                    "Fehlerbeschreibung: " & vbCrLf & _
                    "Datenbankanbindung: " & Mid(ErrorText(0), 2) & " " & Mid( _
                    ErrorText(1), 2) & " " & Mid(ErrorText(2), 2) & vbCrLf & _
                    "Fehler: " & ErrorTextDet(0) & vbCrLf & _
                    "Fehlerdetail: " & vbCrLf & _
                     ErrorTextDet(1) & vbCrLf & _
                    "NativeError: " & oError.NativeError & vbCrLf & _
                    "SQL-Status: " & oError.SQLState & vbCrLf & _
                    "Quelle: " & oError.Source & vbCrLf & vbCrLf
        Next
 
        Meldung "Fehler beim öffnen der Datenbank ...", sError, vbOK + _
          vbCritical
    Else
        Daten_Schreiben FG1, rsPd
    End If
 
End Sub

Wer aufhört sich zu verbessern, hört auf gut zu sein.