Attribute VB_Name = "modODBC"
' #######################################################
' Modul: modODBC
' Autor: Sascha Trowitzsch / AGA
' Zweck: Hilfsfunktionen für ODBC
' ABLAUFSKIZZE:
' -InitTempVars
' -ReadLogin (liefert tvarLastUser, tvarLastPwd, tvarLastDB, tvarLastServer, tvarLastPort, tvarDBPath, tvarLastLogin;
'                           testet Treiber und speichert tvarODBCDriver)
' -StartDB (baut Testverbindung auf; verknüpft ggf. Tabellen und PT-Abfragen)
'  -CanConnectBackend (Verbindung zum Server möglich?)
'  -GetODBCString (ODBC-String ermitteln: Anmeldedialog oder direkte Verbindung: speichert tvarODBCString)
'  -GetUserLogon (Anmeldedialog)
' #######################################################
Option Explicit

'KONSTANTEN
'Hier den MySQL-ODBC-Treiber festlegen (z.B. "MySQL Connector/ODBC v5")
'(möglich ist auch nur 'MySQL'; dann wird beliebiger MySQL-ODBC-Treiber verwendet)
Public Const ThisDriver = "MySQL ODBC 3.51 Driver"

Private Const SQL_FETCH_NEXT As Long = 1
Private Const SQL_FETCH_FIRST As Long = 2
Private Const SQL_SUCCESS As Long = 0
Private Const SQL_NO_DATA_FOUND As Long = 100
Private Const SQL_NTS As Long = -3
Private Const SQL_DROP As Long = 1
Private Const SQL_MAX_DESC_LENGTH As Long = 128
Private Const SQL_MAX_DSN_LENGTH As Long = 32
Private Const SQL_NULL_HANDLE As Long = 0
Private Const SQL_HANDLE_ENV As Long = 1
Private Const SQL_HANDLE_DBC As Long = 2
Private Const SQL_HANDLE_STMT As Long = 3
Private Const SQL_HANDLE_DESC As Long = 4
Private Const SQL_ATTR_ODBC_VERSION As Long = 200
Private Const SQL_OV_ODBC3 As Long = 3
Private Const SQL_IS_INTEGER As Long = (-6)
Private Const ODBC_ADD_DSN As Long = 1
Private Const ODBC_BOTH_DSN As Long = 0
Private Const ODBC_USER_DSN As Long = 1
Private Const ODBC_SYSTEM_DSN As Long = 2
Private Const SQL_NEED_DATA As Long = 99
Private Const SQL_ERROR As Long = -1
Private Const SQL_DRIVER_COMPLETE As Long = 1
Private Const SQL_DRIVER_COMPLETE_REQUIRED As Long = 3
Private Const SQL_DRIVER_NOPROMPT As Long = 0
Private Const SQL_DRIVER_PROMPT As Long = 2

'FUNKTIONEN
Private Declare Function SQLWritePrivateProfileString Lib "odbccp32.dll" (ByVal Section As String, ByVal key As String, ByVal Entry As String, ByVal Init As String) As Long
Private Declare Function SQLAllocHandle Lib "ODBC32.dll" (ByVal HandleType As Integer, ByVal InputHandle As Long, OutputHandlePtr As Long) As Long
Private Declare Function SQLAllocConnect Lib "ODBC32.dll" (ByVal lngEnv As Long, phdbc As Long) As Integer
Private Declare Function SQLAllocEnv Lib "ODBC32.dll" (phenv As Long) As Integer
Private Declare Function SQLFreeEnv Lib "ODBC32.dll" (ByVal lngEnv As Long) As Integer
Private Declare Function SQLFreeHandle Lib "ODBC32.dll" (ByVal HandleType As Integer, ByVal handle As Long) As Long
Private Declare Function SQLAllocStmt Lib "ODBC32.dll" (ByVal lngDbc As Long, lngStmt As Long) As Integer
Private Declare Function SQLFreeStmt Lib "ODBC32.dll" (ByVal lngStmt As Long, ByVal fOption As Integer) As Integer
Private Declare Function SQLSetEnvAttr Lib "ODBC32.dll" (ByVal EnvironmentHandle As Long, ByVal dwAttribute As Long, ByVal ValuePtr As Long, ByVal StringLen As Long) As Long
Private Declare Function SQLConfigDataSource Lib "odbccp32.dll" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
Private Declare Function SQLDataSources Lib "ODBC32.dll" (ByVal lngEnv As Long, ByVal fDirection As Integer, ByVal szDSN As String, ByVal cbDSNMax As Integer, pcbDSN As Integer, ByVal szDescription As String, ByVal cbDescriptionMax As Integer, pcbDescription As Integer) As Integer
Private Declare Function SQLSetConfigMode Lib "odbccp32.dll" (ByVal wConfigMode As Integer) As Long
'Private Declare Function SQLGetPrivateProfileString Lib "ODBCCP32.DLL" '    (ByVal strSection As String, '    ByVal sEntry As String, '    ByVal strDefault As String, '    ByVal sBuffer As String, '    ByVal lBuffer As Long, '    sFile As String) As Long
Declare Function SQLGetPrivateProfileString Lib "odbccp32.dll" (ByVal Section As String, ByVal key As String, ByVal Default As String, ByVal Buffer As String, ByVal BufSize As Integer, ByVal Init As String) As Long
Private Declare Function SQLConnect Lib "ODBC32.dll" (ByVal lngDbc As Long, ByVal szDSN As String, ByVal cbDSN As Integer, ByVal szUID As String, ByVal cbUID As Integer, ByVal szAuthStr As String, ByVal cbAuthStr As Integer) As Integer
Private Declare Function SQLDisconnect Lib "ODBC32.dll" (ByVal lngDbc As Long) As Integer
Private Declare Function SQLFreeConnect Lib "ODBC32.dll" (ByVal lngDbc As Long) As Integer
Private Declare Function SQLBrowseConnect Lib "ODBC32.dll" (ByVal lngDbc As Long, ByVal szConnStrIn As String, ByVal cbConnStrIn As Integer, ByVal szConnStrOut As String, ByVal cbConnStrOutMax As Integer, pcbConnStrOut As Integer) As Integer
Private Declare Function SQLDrivers Lib "ODBC32.dll" (ByVal lngEnv As Long, ByVal fDirection As Integer, ByVal szDriverDesc As String, ByVal cbDriverDescMax As Integer, pcbDriverDesc As Integer, ByVal szDriverAttr As String, ByVal cbDrvrAttrMax As Integer, pcbDrvrAttr As Integer) As Integer
Private Declare Function SQLDriverConnect Lib "ODBC32.dll" (ByVal lngDbc As Long, ByVal hWnd As Long, ByVal szConnStrIn As String, ByVal cbConnStrIn As Integer, ByVal szConnStrOut As String, ByVal cbConnStrOutMax As Integer, ByRef pcbConnStrOut As Integer, ByVal fDriverCompletion As Integer) As Long
Private Declare Function SQLGetDiagRec Lib "ODBC32.dll" (ByVal HandleType As Integer, ByVal HandleType As Long, ByVal RecNum As Integer, ByVal SQLState As String, ByRef Errcode As Long, ByVal sMsg As String, ByVal linMsg As Integer, ByRef lMsb As Integer) As Integer
Private Declare Function GetDesktopWindow Lib "user32" () As Long

'VARIABELN
Public strConnect As String

Public Function CreateDSN(strDriver, strDescription As String, strDSN As String, strAttrib As String, Optional Show = False) As Boolean
' *******************************************************
' Function: CreateDSN
' Parameter: Boolean
' Autor: ST
' Erstellt am: 25.02.2009
' Geändert am: 25.02.2009
' Funktion: Erzeugt eine DSN aus den Angaben: (optional kurzer) Treibername, Beschreibung , DSN - Name, AttributString
' Bei Erfolg wird True zurückgegeben. Eine bestehende DSN gleichen Namens wird überschrieben!
' AttributString: Hier handelt es sich um variable, treiberspezifische Angaben.
' Die einzelnen Attribute müssen durch NullStrings getrennt sein, z.B.:
' strArrib = "SERVER= MeinServer" & Chr(0) & "SERVERDB=MeineDB" & Chr(0) & "UID=Ich"
' Man kann diese Attribute am einfachsten ermitteln, indem man eine Beispiel-DSN erzeugt
' und sich die Einträge in der Registry unter HKEY_CURRENT_USER\SOFTWARE\ODBC\ODBC.INI anschaut
' Wenn Show auf True gesetzt wird, so wird zusätzlich das ODBC-Dialogfenster angezeigt.
' Bsp.: CreateDSN "Access", "(nix)", "MeinAccess", "DBQ=d:\datenbanken\meine.mdb" & chr(0) & "UID=sascha")
' *******************************************************
Dim i As Long


    strDriver = GetRealDriverName(strDriver)(0)

    If strDriver = "Unbekannt" Then Exit Function

    strAttrib = strAttrib & Chr(0) & "DESCRIPTION=" & strDescription & Chr(0)
    strAttrib = strAttrib & "DSN=" & strDSN & Chr(0)

    If Show Then i = Application.hWndAccessApp Else i = 0&
    
    i = SQLConfigDataSource(i, ODBC_ADD_DSN, strDriver, strAttrib)
    CreateDSN = (i <> 0)

End Function

Public Function ListODBCDrivers() As String()
' *******************************************************
' Function: ListODBCDrivers
' Parameter: Variant
' Autor: ST
' Erstellt am: 25.02.2009
' Geändert am: 25.02.2009
' Funktion: Gibt eine Liste aller im System installierten ODBC-Treiber in einem String-Array zurück
' Bsp.: ListODBCDrivers(0) >> "Microsoft Access-Treiber (*.mdb)"
' ODBC-Treiber für MySQL: "MySQL ODBC 3.51 Driver" (falls vorhanden)
' *******************************************************
Dim ret As Long
Dim j As Long
Dim lngEnv As Long
Dim arrDrv() As String
Dim strDriver As String * 512
Dim strAttrib As String * 512
Dim intDrv As Integer
Dim intAtr As Integer


    ret = SQLAllocEnv(lngEnv)

    Do While ret = SQL_SUCCESS
        ret = SQLDrivers(lngEnv, SQL_FETCH_NEXT, strDriver, 512, intDrv, strAttrib, 512, intAtr)
        If ret <> SQL_NO_DATA_FOUND Then
            ReDim Preserve arrDrv(j)
            arrDrv(j) = left(strDriver, intDrv)
            'Debug.Print "Treiber: " & arrDrv(j)
            j = j + 1
        End If
    Loop

    ListODBCDrivers = arrDrv
    Call SQLFreeEnv(lngEnv)

End Function

Public Function GetRealDriverName(strDriverName) As String()
' *******************************************************
' Function: GetRealDriverName
' Parameter: erwartet Treibernamen; liefert installierten MySQL-Treiber
'                         zurück, andernfalls "Unbekannt"
' Autor: ST/AGA
' Erstellt am: 25.02.2009
' Geändert am: 12.03.2009
' Funktion: Gibt zu einem übergebenen abgekürzten ODBC-Treibernamen eine Liste der kompatiblen
' vollständigen Treibernamen in einem String-Array zurück
' Bsp.: GetRealDriverName("MySQL")(0) >> "MySQL ODBC 3.51"
' *******************************************************
Dim arrDrv() As String
Dim arrResult() As String
Dim i As Long
Dim n As Long
Dim j As Long

    
    'Liste der installierten Treiber in Array einlesen
    arrDrv = ListODBCDrivers
    
    'Länge der Liste ermitteln
    On Error Resume Next
    i = UBound(arrDrv)
    On Error GoTo 0

    'Prüft, ob "MySQL ODBC 3.51" unter den Treibern ist
    For n = 0 To i
        If 0 <> InStr(1, arrDrv(n), strDriverName, vbTextCompare) Then
            ReDim Preserve arrResult(j)
            arrResult(j) = arrDrv(n)
            If arrResult(j) = "" Then arrResult(j) = "Unbekannt"
            j = j + 1
        End If
    Next n

    GetRealDriverName = arrResult

End Function

Public Function ODBCDriverExists(ByVal strDriverName As String) As Boolean
' *******************************************************
' Function: ODBCDriverExists
' Parameter: Boolean
' Autor: ST
' Erstellt am: 25.02.2009
' Geändert am: 25.02.2009
' Funktion: Überprüft, ob der angegebene ODBC-Treibername auf dem System existiert
' Bsp.: "MySQL" gibt True zurück, wenn ein "MySQL ODBC 2.5"-Treiber vorhanden ist.
' (Teilstring erlaubt; "MySQL ODBC 3.51" würde in diesem Fall ebenso gültig sein.)
' *******************************************************
Dim ret As Long
Dim l As Long
Dim lngEnv As Long
Dim strTemp As String
Dim strDriver As String * 512
Dim strAttrib As String * 512
Dim intDrv As Integer
Dim intAtr As Integer


    l = Len(strDriverName)
    ret = SQLAllocEnv(lngEnv)

    Do While ret = SQL_SUCCESS
        ret = SQLDrivers(lngEnv&, SQL_FETCH_NEXT, strDriver, 512, intDrv, strAttrib, 512, intAtr)
        If ret <> SQL_NO_DATA_FOUND Then
            strTemp = left(Trim(left(strDriver, intDrv)), l)
            If StrComp(strTemp, strDriverName, vbTextCompare) = 0 Then
                ODBCDriverExists = True
                Exit Do
            End If
        End If
    Loop

    Call SQLFreeEnv(lngEnv)

End Function

Public Function ListAllDriverDSN(ByVal strDSNDriver As String) As String()
' *******************************************************
' Function: ListAllDriverDSN
' Parameter: Variant
' Autor: ST
' Erstellt am: 25.02.2009
' Geändert am: 25.02.2009
' Funktion: Gibt ein String-Array zurück, das alle DSN-Namen im System enthält, die den angegebenen ODBC-Treiber benutzen.
' Bsp.: ListAllDriverDSN("MySQL ODBC 2.5")(0) >> "Meine erste MySQL DSN"
' *******************************************************
Dim lngEnv As Long
Dim arrDSN() As String
Dim strServer As String
Dim strDriver As String
Dim intSvrLen As Integer
Dim intDvrLen As Integer
Dim i As Long
Dim n As Long


    If SQLAllocHandle(SQL_HANDLE_ENV, SQL_NULL_HANDLE, lngEnv) <> 0 Then
        If SQLSetEnvAttr(lngEnv, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC3, SQL_IS_INTEGER) <> 0 Then
            strServer = String(SQL_MAX_DSN_LENGTH, vbNullChar)
            strDriver = String(SQL_MAX_DESC_LENGTH, vbNullChar)
            Do While SQLDataSources(lngEnv, SQL_FETCH_NEXT, strServer, SQL_MAX_DSN_LENGTH, intSvrLen, strDriver, SQL_MAX_DESC_LENGTH, intDvrLen) = SQL_SUCCESS
                strServer = left(strServer, intSvrLen)
                strDriver = left(strDriver, intDvrLen)
                'Debug.Print strDriver
                If InStr(1, strDSNDriver, strDriver, vbTextCompare) <> 0 Then
                    ReDim Preserve arrDSN(n)
                    arrDSN(UBound(arrDSN)) = strServer
                    n = n + 1
                End If
                strServer = String(SQL_MAX_DSN_LENGTH, vbNullChar)
                strDriver = String(SQL_MAX_DESC_LENGTH, vbNullChar)
            Loop
        End If
        Call SQLFreeHandle(SQL_HANDLE_ENV, lngEnv)
    End If

    ListAllDriverDSN = arrDSN

End Function

Public Function CanConnectBackend(Optional bolVerbose As Boolean = True) As Boolean
' *******************************************************
' Function: CanConnectBackend
' Parameter: erwartet bolVerbose ("langatmig"):
'                       "false" = 1. Connect; "true" = 2. Anlauf zur Fehlerermittlung; liefert Boolean
' Autor: ST/AGA
' Erstellt am: 25.02.2009
' Geändert am: 10.03.2009
' Funktion: Prüft, ob eine Verbindung zum Server möglich ist und
' ermittelt Fehlerursache, falls Probleme auftreten
' *******************************************************
Dim lngEnv As Long
Dim lngDbc As Long
Dim strConnect2 As String
Dim strMsg As String * 256
Dim intMsg As Integer
Dim strState As String * 5
Dim lngError As Long
Dim strTemp As String
Dim n As Integer
Dim ret As Long


    On Error GoTo LocalErrorHandler
   
   'ODBC-Connectionstring ermitteln (aus Login-Dialog oder preLogin.accde)
    strConnect = GetODBCString()
        
    'Ist beim Login Abbruch erfolgt?
    If strConnect = "xxxxx" Then
        MsgBox "Es konnte keine Verbindung  zum Server hergestellt werden!" & vbNewLine & _
                            "preConSulT 3 wird nun beendet ...", vbCritical, "preConSulT 3"
        ShutDownDB
    End If
        
    'ODBC-Treiber-Prüfungen vornehmen:
    ret = SQLAllocEnv(lngEnv)
    ret = SQLAllocConnect(ByVal lngEnv, lngDbc)
    
    If ret = SQL_SUCCESS Then '0 = alles OK
        strConnect = Mid(strConnect, 6) 'entfernt das führende "ODBC;"
        strConnect2 = Space$(2048)
        
        'Verbindungsversuch zum Server: SQL_Success (= 0), wenn erfolgreich
        ret = SQLDriverConnect(lngDbc, 0&, strConnect, Len(strConnect), strConnect2, Len(strConnect2), n, SQL_DRIVER_NOPROMPT)
        
        'Alles in Ordnung?
        If (Err.Number = 0) And (ret = SQL_SUCCESS) Then
            CanConnectBackend = True
        Else 'Verbindungsprobleme?
            If bolVerbose Then 'zweiter Connect-Versuch: bolVerbose = True
                strMsg = String(255, vbNullChar)
                'Fehlermeldung zur Fehlernummer generieren
                Call SQLGetDiagRec(SQL_HANDLE_DBC, lngDbc, 1, strState, lngError, strMsg, 255, intMsg)
                If lngError = 2003 Then 'Serververbindung schlägt fehl
                    MsgBox "Verbindung zum Server kann nicht aufgebaut werden!", vbExclamation, "preConSulT 3"
                Else 'ansonsten: ODBC-Fehler ermitteln
                    strTemp = GetODBCError(strState)
                    DoCmd.Hourglass False
                    MsgBox strTemp & vbNewLine & "ODBC-Subsystem meldet:" & vbNewLine & left(strMsg, intMsg), vbCritical, "preConSulT 3"
                End If
            Else 'Verbindungsprobleme: zweiter Anlauf
                MsgBox "Die Anmeldung am Server ist fehlgeschlagen!" & vbNewLine _
                             & "Bitte kontrollieren Sie Ihre Eingaben ...", vbInformation, "preConSulT 3"
            End If
        End If
    End If


Cleanup:
    On Error Resume Next
    DoCmd.Hourglass False
    'Testverbindung wieder abbauen
    If lngDbc <> 0 Then SQLDisconnect ByVal lngDbc
    If lngEnv <> 0 Then SQLFreeEnv ByVal lngEnv
    Exit Function
    
LocalErrorHandler:
    'Ausgewählte Fehler hier behandeln
    Select Case Err.Number
    'Case xxx
    End Select
    
    'unbehandelte Fehler an GEH durchreichen
    ErrEx.CallGlobalErrorHandler
    Resume Cleanup

End Function

Public Function CheckDSNConnect(ByVal strDSN, ByVal strUser As String, ByVal strPW As String) As String
' *******************************************************
' Function: CheckDSNConnect
' Parameter: String
' Autor: ST
' Erstellt am: 25.02.2009
' Geändert am: 25.02.2009
' Funktion: Testet die DSN. Es wird eine Connection aufgebaut:
' Angabe von DSN-Name, Username, Passwort erforderlich
' Bei Fehler wird eine ODBC-Treibermeldung zurückgegeben.
' Bsp. CheckDSNConnect("MeinMySQL", "Sascha", " Trowitzsch") >> "Invalid user id and/or password"
' *******************************************************
Dim lngEnv As Long
Dim lngDbc As Long
Dim lngStmt As Long
Dim ret As Long
Dim strTemp As String
Dim strMsg As String * 256
Dim intMsg As Integer
Dim strState As String * 5
Dim lngError As Long


    ret = SQLAllocEnv(lngEnv)
    ret = SQLAllocConnect(ByVal lngEnv, lngDbc)

    If ret = SQL_SUCCESS Then
        ret = SQLConnect(lngDbc, ByVal strDSN & vbNullChar, Len(strDSN), ByVal strUser & vbNullChar, Len(strUser) + 1, ByVal strPW & vbNullChar, Len(strPW) + 1)

        If ret <> 0 Then
            strMsg = String(255, vbNullChar)
            Call SQLGetDiagRec(SQL_HANDLE_DBC, lngDbc, 1, strState, lngError, strMsg, 255, intMsg)
            strTemp = GetODBCError(strState)
            CheckDSNConnect = "- " & strTemp & "-" & vbNewLine & _
                              "ODBC-Subsystem meldet:" & vbNewLine & _
                              Chr(34) & left(strMsg, intMsg) & Chr(34)
        Else
            CheckDSNConnect = "Verbindung zu " & strDSN & " war erfolgreich!"
        End If
        ret = SQLDisconnect(ByVal lngDbc)
    End If

    ret = SQLFreeEnv(ByVal lngEnv)
    ret = SQLFreeStmt(lngStmt, SQL_DROP)

End Function

Public Function GetODBCErrNr(ByVal strErrDescription As String) As String
' *******************************************************
' Function: GetODBCErrNr
' Parameter: erwartet Error-Message; liefert Nummer als String
' Autor: AGA
' Erstellt am: 26.07.2010
' Geändert am: 26.07.2010
' Funktion: liefert (letzte) ODBC-Fehler-Nr. als String zurück
' *******************************************************
Dim intPosStart As Integer
Dim intLength As Integer


    'Anfang der Fehlernummer suchen (beginnt mit "#")
    intPosStart = InStr(1, strErrDescription, "#") + 1
    'Länge der Fehlernummer bestimmen (endet mit ")")
    intLength = InStr(intPosStart, strErrDescription, ")") - intPosStart
    'ODBC-Error-Nummer auslesen
    GetODBCErrNr = Mid(strErrDescription, intPosStart, intLength)
    
        
End Function

Public Function GetODBCError(strError As String) As String
' *******************************************************
' Function: GetODBCError
' Parameter: String
' Autor: ST/AGA
' Erstellt am: 25.02.2009
' Geändert am: 26.07.2010
' Funktion: Fehlermeldungen des ODBC-Systems (vom Treiber) in Text umwandeln
'                      Das hier ist eine Mischung aus allgemeinen ODBC-Fehlern und
'                      MySQL-ODBC-spezifischen Fehlermeldungen
' *******************************************************

    Select Case strError
    Case "1000", "01000"
        GetODBCError = "Allgemeiner Treiber-Fehler!"
    Case "01004", "1004"
        GetODBCError = "Rückgabe-String abgeschnitten!"
    Case "1062"
        GetODBCError = "Doppelter Schlüsseleintrag!"
    Case "01S02"
        GetODBCError = "Ein oder mehrere Parameter sind ungültig!"
    Case "01S03"
        GetODBCError = "Datensatz konnte nicht gelöscht oder aktualisiert werden!"
    Case "01S04"
        GetODBCError = "Mehr als ein Datensatz würde gelöscht oder aktualisiert werden!"
    Case "01S06"
        GetODBCError = "Synchronisationsfehler!"
    Case "7001", "7002"
        GetODBCError = "ODBC-SQL: SQLBindParameter wurde nicht für alle Parameter verwendet!"
    Case "7005"
        GetODBCError = "ODBC-SQL: Prepared Statement ohne Cursor-Spezifikation!"
    Case "7009"
        GetODBCError = "Ungültiger Descriptor-Index!"
    Case "08001"
        GetODBCError = "Es konnte keine Verbindung aufgebaut werden!"
    Case "08002"
        GetODBCError = "Es konnte keine weitere Verbindung aufgebaut werden!"
    Case "08003"
        GetODBCError = "Diese Verbindung existiert nicht (mehr)!"
    Case "08004"
        GetODBCError = "Der SQL-Server wies die Verbindungsanfrage zurück (implementation error)!"
    Case "24000"
        GetODBCError = "Ungültiger Cursor-Status!"
    Case "25000"
        GetODBCError = "Ungültiger Transaktionsstatus!"
    Case "25S01"
        GetODBCError = "Unbekannter Transaktionsstatus!"
    Case "34000"
        GetODBCError = "Ungültiger Cursor-Name!"
    Case "S1000", "HY000"
        GetODBCError = "Allgemeiner Treiberfehler!"
    Case "S1001", "HY001"
        GetODBCError = "Fehler beim Speicherzugriff!"
    Case "S1002", "HY002"
        GetODBCError = "Ungültige Spaltennummer!"
    Case "S1003", "HY003"
        GetODBCError = "Übergebener Speicherpuffer ungültig!"
    Case "S1004", "HY004"
        GetODBCError = "Ungültiger SQL-Datentyp übergeben!"
    Case "S1009", "HY009"
        GetODBCError = "Falsche Benutzung eines Null-Zeigers!"
    Case "S1010", "HY010"
        GetODBCError = "Fehler beim Abarbeiten einer Funktionssequenz!"
    Case "S1011", "HY011"
        GetODBCError = "Attribut kann augenblicklich nicht gesetzt werden!"
    Case "S1012", "HY012"
        GetODBCError = "Ungültiger Transaktionsmodus!"
    Case "S1013", "HY013"
        GetODBCError = "Fehler in Speichermanagement!"
    Case "S1015", "HY015"
        GetODBCError = "Kein Cursor-Name verfügbar!"
    Case "S1024", "HY024"
        GetODBCError = "Ungültiger Attributwert!"
    Case "S1090", "HY090"
        GetODBCError = "Ungültige String- oder Puffergröße!"
    Case "S1091", "HY091"
        GetODBCError = "Ungültig: Descriptor Field Identifier!"
    Case "S1092", "HY092"
        GetODBCError = "Ungültig: Attribute/Option Identifier!"
    Case "S1093", "HY093"
        GetODBCError = "Ungültige Parameterzahl!"
    Case "S1095", "HY095"
        GetODBCError = "Funktionstyp außerhalb des gültigen Bereichs!"
    Case "S1106", "HY106"
        GetODBCError = "Zugriffstyp außerhalb des gültigen Bereichs!"
    Case "S1117", "HY117"
        GetODBCError = "Zeilenwert außerhalb des gültigen Bereichs!"
    Case "S1109", "HY109"
        GetODBCError = "Falsche Cursor-Position!"
    Case "S1C00", "HYC00"
        GetODBCError = "Dieses optionale Feature ist nicht implementiert!"
    Case "21S01", "21S01"
        GetODBCError = "Spaltenanzahl entspricht nicht der Werteanzahl!"
    Case "23000", "23000"
        GetODBCError = "Integritätsverletzung!"
    Case "42000", "42000"
        GetODBCError = "Syntaxfehler oder Zugriffsverletzung!"
    Case "42S02", "42S02"
        GetODBCError = "Eine Basistabelle oder -View wurde nicht gefunden!"
    Case "42S12", "42S12"
        GetODBCError = "Index wurde nicht gefunden!"
    Case "42S21", "42S21"
        GetODBCError = "Diese Spalte existiert bereits!"
    Case "42S22", "42S22"
        GetODBCError = "Spalte nicht gefunden!"
    Case "08S01"
        GetODBCError = "Kommunikationsfehler zwischen Treiber und Datenquelle!"
    Case "28000"
        GetODBCError = "Ungültige Anmelde- und/oder Kennwortangabe(n)!"
    Case "HY090"
        GetODBCError = "Ungültiger Parameter!"
    Case "HYT00", "HYT01"
        GetODBCError = "Timeout bei Verbindungsversuch!"
    Case "IM001"
        GetODBCError = "Ein übergebenes Attribut wird vom Treiber nicht unterstützt!"
    Case "IM002"
        GetODBCError = "ODBC-Datenquelle (DSN) wurde nicht gefunden!"
    Case "IM003"
        GetODBCError = "Der angegebene ODBC-Treiber wurde nicht gefunden!"
    Case "IM004", "IM005", "IM006"
        GetODBCError = "ODBC-Treiberfehler!"
    Case "IM009"
        GetODBCError = "ODBC-Treiber meldet einen DLL-Fehler!"
    Case "IM010"
        GetODBCError = "Ungültiger DSN-Name: Name zu lang!"
    Case Else
        GetODBCError = "Unbekannter Fehler: " & strError
    End Select

End Function

Public Function GetDSNEntries(Optional ShowAttributes = True)
' *******************************************************
' Function: GetDSNEntries
' Parameter: Variant
' Autor: ST
' Erstellt am: 25.02.2009
' Geändert am: 25.02.2009
' Funktion: Alle ODBC-Datenquellen (DSN) im System auslesen
'ShowAttributes: Wenn True (Vorgabe), dann werden zusätzlich deren Attribute angezeigt
'Ausgabe im Direktfenster!
' *******************************************************
Dim lngEnv As Long
Dim strServer As String
Dim strDriver As String
Dim intSvrLen As Integer
Dim intDvrLen As Integer


    SQLAllocHandle SQL_HANDLE_ENV, SQL_NULL_HANDLE, lngEnv

    If lngEnv <> 0 Then

        If SQLSetEnvAttr(lngEnv, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC3, SQL_IS_INTEGER) <> 0 Then
            strServer = String(SQL_MAX_DSN_LENGTH, vbNullChar)
            strDriver = String(SQL_MAX_DESC_LENGTH, vbNullChar)

            Do While SQLDataSources(lngEnv, SQL_FETCH_NEXT, strServer, SQL_MAX_DSN_LENGTH, intSvrLen, strDriver, SQL_MAX_DESC_LENGTH, intDvrLen) = SQL_SUCCESS
                strServer = left(strServer, intSvrLen)
                Debug.Print "DSN: " & strServer

                If ShowAttributes Then GetSectionsDSN strServer    'Siehe unten

                strServer = String(SQL_MAX_DSN_LENGTH, vbNullChar)
                strDriver = String(SQL_MAX_DESC_LENGTH, vbNullChar)
            Loop
        End If
        Call SQLFreeHandle(SQL_HANDLE_ENV, lngEnv)
    End If

End Function

Public Function GetSectionFromDSN(sDSN As String, strSection As String) As String
' *******************************************************
' Function: GetSectionFromDSN
' Parameter: String
' Autor: ST
' Erstellt am: 25.02.2009
' Geändert am: 25.02.2009
' Funktion: Einzelnes Attribut einer ODBC-Datenquelle(DSN) auslesen
' *******************************************************
Dim strBuffer As String
Dim n As Long
Dim ret As Long


    ret = SQLSetConfigMode(ODBC_USER_DSN)

    If Not CBool(ret) Then
        MsgBox "ODBC-Initialisierung gescheitert!"
    Else
        strBuffer = String$(512, 0)
        n = SQLGetPrivateProfileString(sDSN, strSection, "DSN oder Eigenschaft nicht gefunden!", strBuffer, 511, "ODBC.INI")
        GetSectionFromDSN = left(strBuffer, n)
    End If

End Function

Public Function GetSectionsDSN(Optional sDSN As String) As String
' *******************************************************
' Function: GetSectionsDSN
' Parameter: String
' Autor: ST
' Erstellt am: 25.02.2009
' Geändert am: 25.02.2009
' Funktion: Alle Attribute einer ODBC-Datenquelle(DSN) ausgeben
' *******************************************************
Dim strSection As String
Dim strResult As String
Dim arrSections() As String
Dim strDefault As String
Dim strBuffer As String
Dim n As Long
Dim i As Long
Dim ret As Long


    ret = SQLSetConfigMode(ODBC_BOTH_DSN)       'Oder ODBC_USER_DSN,  ODBC_SYSTEM_DSN

    If Not CBool(ret) Then
        MsgBox "ODBC-Initialisierung gescheitert!", vbExclamation, "preConSulT 3"
    Else
        strDefault = "DSN-Eigenschaft nicht gefunden!"
        strBuffer = String$(512, 0)
        n = SQLGetPrivateProfileString(vbNullString, vbNullString, vbNullString, strBuffer, 512, "ODBC.INI")
        strBuffer = String$(512, 0)
        strSection = vbNullString
        'Attribute auslesen (strSection = "")
        n = SQLGetPrivateProfileString(sDSN, strSection, "DSN nicht gefunden!", strBuffer, 512, "ODBC.INI")

        If n = 0 Then Exit Function

        strSection = left(strBuffer, n - 1)
        'Attribut-String ist chr(0)-separiert; in Array splitten:
        arrSections = Split(strSection, vbNullChar)

        'Attributte enumerieren:
        For i = 0 To UBound(arrSections)
            If Len(arrSections(i)) > 0 Then
                strBuffer = String$(512, 0)
                n = SQLGetPrivateProfileString(sDSN, arrSections(i), strDefault, strBuffer, 512, "ODBC.INI")
                strSection = left(strBuffer, n)
                'Debug.Print vbTab & arrSections(i) & " = " & strSection
                strResult = strResult & arrSections(i) & " = " & strSection & vbNewLine
            End If
        Next i
    End If

    If Len(strResult) > 2 Then GetSectionsDSN = left(strResult, Len(strResult) - 2)

End Function

Public Sub SetSectionToDSN(strDSN As String, strSection As String, strEntry As String)
' *******************************************************
' Sub: SetSectionToDSN
' Parameter:
' Autor: ST
' Erstellt am: 25.02.2009
' Geändert am: 25.02.2009
' Funktion: Einzelne Eigenschaft einer existierenden DSN setzen (bzw. überschreiben)
' *******************************************************
Dim strBuffer As String
Dim n As Long
Dim ret As Long


    ret = SQLSetConfigMode(ODBC_USER_DSN)

    If Not CBool(ret) Then
        MsgBox "ODBC-Initialisierung gescheitert!", vbExclamation, "preConSulT 3"
    Else
        strBuffer = String$(512, 0)
        n = SQLWritePrivateProfileString(strDSN, strSection, strEntry, "ODBC.INI")
        If n = 0 Then MsgBox "Setzen der Eigenschaft war nicht erfolgreich", vbCritical, "preConSulT 3"
    End If

End Sub

Public Function RefreshLinks(Optional ForceRefresh As Boolean) As Boolean
' *******************************************************
' Function: RefreshLinks
' Parameter: optional: ForceRefresh verknüft in jedem Fall; liefert Boolean
' Autor: AGA
' Erstellt am: 26.02.2009
' Geändert am: 20.02.2010
' Funktion: Aktualisiert die Verknüpfungen für Tabellen und PT-Abfragen
' *******************************************************
Dim tdf As DAO.TableDef
Dim qdf As DAO.QueryDef
Dim strHelpPath As String 'Pfad zur preHelp.accde
Dim strWzPath As String 'Pfad zur preWz08.accde (beide im lokalen preConSulT 3-Verzeichnis)
Dim strTabKz As String 'für Tabellenpräfix
Dim strODBC As String 'aktueller ODBC-String aus Login
Dim strConx As String 'für neuen Connectionstring
Dim strBase As String 'aktueller Connectionstring der ODBC-Tabelle


    On Error GoTo LocalErrorHandler

    'Dialogfenster öffnen
    'DoCmd.OpenForm "frmDlgRelink"
    
    DoCmd.Hourglass True
    'aktuellen Connectionstring (nach Login) ermitteln
    strBase = GetTVar("tvarODBCString")
    
    If Len(strBase) = 0 Then GoTo Cleanup
    
    'Hilfsdatenbanken ermitteln
    strHelpPath = GetPath(CurrentDbC.Name) & "preHelp.accde"
    strWzPath = GetPath(CurrentDbC.Name) & "preWZ08.accde"
                    
    'alle Tabellen der Datenbank durchlaufen
    For Each tdf In CurrentDbC.TableDefs
        'geprüft wird in alphabetischer Reihenfolge (inkl. Systemtabellen);
        'Präfix (die ersten zwei Zeichen) der jeweiligen Tabelle auslesen:
        'hl = hlp* - Tabellen aus Help.mdb
        'wz = wz* - Tabellen aus Wz.mdb
        'xx = xx* - lokale Tabellen aus Frontend
        '(alle anderen sind ODBC-verknüpfte Tabellen vom Server)
        strTabKz = left(tdf.Name, 2)
        
        'wenn die Tabelle einen Connection-String besitzt, ist sie verknüpft
        If Len(tdf.Connect) > 0 Then
            'Dialog ausgeben
            'Forms!frmDlgRelink!txtObjekt.Caption = tdf.Name
            'Auswahl in Abhängigkeit vom Präfix
            Select Case strTabKz
                Case "hl"
                    ';DATABASE=LW:\Pfad\preHelp.accde
                    tdf.Connect = ";DATABASE=" & strHelpPath
                    'Tabelle mit Connectionstring verlinken
                    tdf.RefreshLink
                Case "wz"
                    ';DATABASE=LW:\Pfad\preWZ08.accde
                    tdf.Connect = ";DATABASE=" & strWzPath
                    'Tabelle mit Connectionstring verlinken
                    tdf.RefreshLink
                Case "xx" 'lokale Tabellen im Frontend nicht verknüpfen
                    If tdf.Name = "xxRelease" Then GoTo WEITER
                Case "~T" 'evt. temporäre Resttabellen
                    SendStatus ("ERROR - temporäre Tabelle gefunden!")
                    GoTo WEITER
                Case Else 'für alle anderen Tabellen (ODBC): (tab*, sd*, rel*)
                    'enthält der Connection-String einer Tabelle die Zeichenfolge "ODBC",
                    If left(tdf.Connect, 4) = "ODBC" Then
                        strConx = strBase & "TABLE=" & tdf.Name & ";"
                        'dann prüfen, ob sich dieser vom aktuellen Connectionstring
                        '(tvarODBCString) unterscheidet: Ja -> Neuverknüpfen
                        If (tdf.Connect <> strBase) Or ForceRefresh Then
                            tdf.Connect = strBase
                            tdf.RefreshLink
                        End If
                    End If
            End Select
                        
            If Err <> 0 Then        'Err = 3011, wenn Tabelle nicht gefunden
                RefreshLinks = False
                'Dialogfenster schließen
                'DoCmd.Close acForm, "frmDlgRelink"
                MsgBox "Fehler bei Tabelle " & tdf.Name & " in Datenbank " & GetTVar("tvarLastDB") & "!" & vbNewLine _
                                & "Bitte kontaktieren Sie den Hersteller.", vbCritical, "preConSulT 3"
                Exit Function
            End If
        End If
WEITER:
    Next tdf

    'Passthrough-Abfragen neu verlinken
    For Each qdf In CurrentDbC.QueryDefs
        'läuft die abf über ODBC?
        If left(qdf.Connect, 4) = "ODBC" Then
            'ist der Connectionstring auf den aktuellen User eingestellt?
            If (qdf.Connect <> strBase) Or ForceRefresh Then
                qdf.Connect = strBase
            End If
            qdf.Close
            If Err <> 0 Then        'Err = 3011, wenn Tabelle nicht gefunden
                RefreshLinks = False
                MsgBox "Fehler bei PT-Abfrage " & qdf.Name & " in Modul " & conModulName & "!" & vbNewLine _
                                & "Bitte kontaktieren Sie den Hersteller.", vbCritical, "preConSulT 3"
                Exit Function
            End If
        End If
    Next qdf
    
    'Relinking erfolgreich abgeschlossen
    RefreshLinks = True
    DoCmd.Hourglass False
    SendStatus ("OK - Tabellen erfolgreich eingebunden ...")
    'Dialogfenster schließen
    'DoCmd.Close acForm, "frmDlgRelink"

Cleanup:
    On Error Resume Next
    DoCmd.Hourglass False
    Set tdf = Nothing
    Set qdf = Nothing
    Exit Function
    
LocalErrorHandler:
    'Ausgewählte Fehler hier behandeln
    Select Case Err.Number
    'case xxx
    End Select
    
    DoCmd.Hourglass False
    'unbehandelte Fehler an GEH durchreichen
    ErrEx.CallGlobalErrorHandler
    Resume Cleanup
    
End Function

Public Function GetODBCString() As String
' *******************************************************
' Function: GetODBCString
' Parameter: liefert den Connection-String für ODBC
' Autor: ST/AGA
' Erstellt am: 25.02.2009
' Geändert am: 25.02.2009
' Funktion: Verbindungsstring für ODBC-Treiber ermitteln:
'                      Server: localhost oder IP/Name
'                      Port: 3306 (oder 4040 = MySQL-Proxy: Tool für Analyse; vgl. AiU 3/08, S. 27)
'                      Datenbank, User, PW: Dialogauswahl
'                      Parameter = 67108906 (Alt: 43)
'                      1 -> do not optimize column width -> entfallen
'                      2 -> return matching rows
'                      8 -> allow big results
'                      32 -> enable dynamic cursor
'                      67108864 -> allow multiple statements - sonst Dutzende Connections
'                      Achtung: Erhöht die Gefährdung durch SQL-Injections!
' *******************************************************
Dim arrUser() As String 'String-Array für Userlogin
    
    
    'Login-Status prüfen:
    If CheckLogin = True Then 'Master-Login bereits erfolgt? (= xxLogin.LoginAkt = true)
                                                         '-> alte Login-Daten sind in TempVars gespeichert (kein Anmeldedialog)
        strConnect = "ODBC;Driver={" & GetTVar("tvarODBCDriver") & "};" & _
                     ";DATABASE=" & GetTVar("tvarLastDB") & _
                     ";SERVER=" & GetTVar("tvarLastServer") & _
                     ";PORT=" & GetTVar("tvarLastPort") & _
                     ";UID=" & GetTVar("tvarLastUser") & _
                     ";PWD=" & GetTVar("tvarLastPwd") & ";OPTION=67108906;"
                     
    Else 'Erster Login oder Modulaufruf ohne Master (= xxLogin.LoginAkt = false)
        'Login-Dialog aufrufen und PW (evt. geänderte User, Datenbank, Server/Port-Info) ermitteln
        arrUser = GetUserLogon()
        
        'Abbruch erfolgt (user= xxxxx)?
        If (arrUser(0) = "xxxxx") Then
            GetODBCString = "xxxxx"
            Exit Function
        End If
            
        'Verbindungsdaten übergeben
        strConnect = "ODBC;Driver={" & GetTVar("tvarODBCDriver") & "};" & _
                     ";DATABASE=" & arrUser(2) & _
                     ";SERVER=" & arrUser(3) & _
                     ";PORT=" & arrUser(4) & _
                     ";UID=" & arrUser(0) & _
                     ";PWD=" & arrUser(1) & ";OPTION=67108906;" 'Alt: 43
                     
        'Login in TempVars protokollieren (temporär; endgültig in AutoExec nach Verknüpfung)
        SetTVar "tvarLastUser", arrUser(0)
        SetTVar "tvarLastPwd", arrUser(1)
        SetTVar "tvarLastDB", arrUser(2)
        SetTVar "tvarLastServer", arrUser(3)
        SetTVar "tvarLastPort", arrUser(4)
        
    End If
    
    'Connectionstring übergeben (strConnect = Public)
    GetODBCString = CStr(strConnect)
    'Connectionstring in TempVars speichern
    SetTVar "tvarODBCString", CStr(strConnect)
    
    
End Function

Public Function GetUserLogon() As String()
' *******************************************************
' Function: GetUserLogon
' Parameter: liefert String-Array mit User-Infos
' Autor: ST
' Erstellt am: 25.02.2009
' Geändert am: 25.02.2009
' Funktion: User-Login + gewünschte Datenbank abfragen (frmLogin)
' *******************************************************
Dim arrUser(4) As String

    'Userdaten in Login-Formular abfragen (bleibt geöffnet)
    DoCmd.Hourglass False
    DoCmd.OpenForm "frmLogin", acNormal, , , , acDialog
    DoCmd.Hourglass True
        
    'Userdaten auslesen
    arrUser(0) = Nz(LCase(Forms!frmLogin!txtLastUser.Value))
    arrUser(1) = Nz(Forms!frmLogin!txtLastPwd.Value)
    arrUser(2) = Nz(LCase(Forms!frmLogin!txtLastDB.Value))
    arrUser(3) = Nz(Forms!frmLogin!txtLastServer.Value)
    arrUser(4) = Nz(Forms!frmLogin!txtLastPort.Value)
    
    'Login-Formular schließen
    DoCmd.Close acForm, "frmLogin"
    'Login-Daten übergeben
    GetUserLogon = arrUser
    
End Function

Public Function StartDB(Optional strConnectMode As String = "normal") As Boolean
' *******************************************************
' Function: StartDB
' Parameter: optional; liefert True, wenn alles ok ist
' Autor: ST/AGA
' Erstellt am: 25.02.2009
' Geändert am: 12.03.2009
' Funktion: Initialisierung der Datenbank: kann Verbindung aufgebaut werden?
'                      (Aufruf aus AutoExec)
' *******************************************************

    'Verbindungsversuch zum Server
    If Not CanConnectBackend(False) Then    'erster Connect-Versuch: bolVerbose = False
        If Not CanConnectBackend(True) Then  'zweiter  Connect-Versuch: bolVerbose = True
                                                                                        'wenn der fehlschlägt -> Fehler ermitteln + Ende
            MsgBox "Es konnte keine Verbindung  zum Server hergestellt werden!" & vbNewLine & _
                            "preConSulT 3 wird nun beendet ...", vbCritical, "preConSulT 3"
            StartDB = False
            Exit Function
        End If
    End If
     
    'Neuverknüpfen der Tabellen & PT-Abfragen
    If Not RefreshLinks(False) Then
        MsgBox "Das Verknüpfen der Datentabellen ist fehlgeschlagen!" & vbNewLine & _
                        "preConSulT wird nun beendet ...", vbCritical, "preConSulT 3"
        StartDB = False
        Exit Function
    End If

    'alles in Ordnung?
    StartDB = True
    
End Function

Sub FromLUA(strLog As String)
    'Debug.Print "LUA called this: " & strLog
End Sub

Public Sub AlterCollation(strMySQLDB As String)
' *******************************************************
' Sub: AlterCollation
' Parameter:
' Autor: ST / AGA
' Erstellt am: 25.02.2009
' Geändert am: 25.02.2009
' Funktion: Aufruf: AlterCollation("daten") (Sascha Trowitzsch, 2009)
' Funktion ändert die Collation für Datenbanken, die nicht die korrekten Einstellungen haben.
' Sie produziert ein SQL-Script, das dann in MySQL ausgeführt wird. Übergeben wird der Name der MySQL-DB,
' ausgeführt wird sie innerhalb der MDB, die bereits alle verknüpften ODBC-Tabellen enthält.
' ACHTUNG: Löscht Kommentare und NotNull-Werte der Spalten (MySQL 5.1.30)!
' *******************************************************
Dim tdf As TableDef
Dim dbs As Database
Dim fld As DAO.field
Dim strSingle As String
Dim strAlter As String
Dim i As Long
    
    
    Set dbs = CurrentDb
    
    'Fremdschlüsselprüfung ausschalten
    strAlter = "SET FOREIGN_KEY_CHECKS = 0;" & vbNewLine
    
    For Each tdf In dbs.TableDefs
        If Len(tdf.Connect) > 0 Then
            If left(tdf.Connect, 4) = "ODBC" Then
                strSingle = "ALTER TABLE `" & strMySQLDB & "`.`" & tdf.Name & "` CHARACTER SET latin1 COLLATE latin1_german2_ci;"
                strAlter = strAlter & strSingle & vbNewLine
                strSingle = "ALTER TABLE `" & strMySQLDB & "`.`" & tdf.Name & "` "
                i = 0
                For Each fld In tdf.Fields
                    Select Case fld.type
                    Case dbText
                        strSingle = strSingle & "MODIFY COLUMN `" & fld.Name & "` VARCHAR(" & fld.size & ") CHARACTER SET latin1 COLLATE latin1_german2_ci, "
                        i = i + 1
                    Case dbMemo
                        strSingle = strSingle & "MODIFY COLUMN `" & fld.Name & "` TEXT CHARACTER SET latin1 COLLATE latin1_german2_ci, "
                        i = i + 1
                    End Select
                Next fld
                If i > 0 Then
                    strSingle = left(strSingle, Len(strSingle) - 2) & ";"
                    strAlter = strAlter & strSingle
                End If
            End If
        End If
    Next tdf
    
    'Fremdschlüsselprüfung einschalten
    strAlter = strAlter & vbNewLine & "SET FOREIGN_KEY_CHECKS = 1;"
    
    Dim f As Integer
    f = FreeFile
    Open CurrentProject.Path & "\altercollation.sql" For Binary As f
    Put f, , strAlter
    Close f
    
    Set tdf = Nothing
    Set dbs = Nothing
    
End Sub

Function CheckDriver() As Boolean
' *******************************************************
' Function: CheckDriver
' Parameter: liefert True/False
' Autor: AGA
' Erstellt am: 12.03.2009
' Geändert am: 12.03.2009
' Funktion: prüft, ob der angegebene ODBC-Treiber im System existiert
' *******************************************************
Dim strODBCTreiber As String


    DoCmd.Hourglass True
    On Error Resume Next
    'ODBC-Treiber ermitteln
    strODBCTreiber = GetRealDriverName(ThisDriver)(0)
    DoCmd.Hourglass False
    On Error GoTo LocalErrorHandler

    'wenn der Treiber nicht gefunden wurde: Abbruch
    If (Len(strODBCTreiber) = 0 Or strODBCTreiber = "Unbekannt") Then
        MsgBox "Der Treiber '" & ThisDriver & "' konnte nicht gefunden werden!" & vbNewLine _
                    & "Bitte benachrichtigen Sie Ihre EDV - perConSulT 3 wird beendet ...", vbCritical, "preConSulT 3"
        CheckDriver = False
        Exit Function
    Else 'Name zur weiteren Verwendung speichern
        SetTVar "tvarODBCDriver", strODBCTreiber
        CheckDriver = True
    End If
    
    
Cleanup:
    'On Error Resume Next
    'Hier aufräumen
    Exit Function
    
LocalErrorHandler:
    'Ausgewählte Fehler hier behandeln
    Select Case Err.Number
    'case xxx
    End Select
    
    'unbehandelte Fehler an GEH durchreichen
    ErrEx.CallGlobalErrorHandler
    Resume Cleanup

End Function

Public Sub CreatePT(strQueryName As String, Optional strSQL As String, Optional strConnect As String, Optional bolReturnsRecords As Boolean = True)
' *******************************************************
' Sub: CreatePT
' Parameter:
' Autor: AGA
' Erstellt am: 22.06.2009
' Geändert am: 20.02.2010
' Funktion: erzeugt Pass-through-Abfrage aus übergebenen Parametern
' Aufruf:      call CreatePT(abfName_pt, strSQL, [connectionstring], True),
'                      danach Aufruf der erzeugten Abfrage mit: currendb.execute "abfName_pt"
' Achtung : Der SQL-String muss im Nachhinein angegeben werden, weil
'                      DAO sonst davon ausgeht, dass es sich um eine lokale ABF handelt
' *******************************************************
Dim qdf As DAO.QueryDef


    On Error Resume Next
    
    DoCmd.DeleteObject acQuery, strQueryName
    
    If Err.Number = 7874 Then 'Objekt nicht gefunden
        Err.Clear
    End If
    
    On Error GoTo LocalErrorHandler
       
    'Abfrage anlegen
    Set qdf = CurrentDbC.CreateQueryDef(strQueryName)
    
    'den SQL-String übergeben
    If Len(strSQL) > 0 Then
        qdf.SQL = strSQL
    End If
    
    'den Connectionstring übergeben
    If Len(strConnect) > 0 Then
        'Neuen Connectionstring nutzen
        qdf.Connect = strConnect
    Else
        'Standardconnection nutzen
        qdf.Connect = GetTVar("tvarODBCString")
    End If
    
    'liefert die ABF Daten?
    qdf.ReturnsRecords = bolReturnsRecords
    
    qdf.Close

Cleanup:
    'On Error Resume Next
    Set qdf = Nothing
    Exit Sub
    
LocalErrorHandler:
    'Ausgewählte Fehler hier behandeln
    Select Case Err.Number
    'case xxx
    End Select
    
    'unbehandelte Fehler an GEH durchreichen
    ErrEx.CallGlobalErrorHandler
    Resume Cleanup
End Sub

