Open con db

 all first Parts in a Module
First Part A

'Verweis auf Microsoft Office Object Library nicht vergessen!!!

Public Function GetDateiname(strInitialFileName As String) As String
Dim f As Office.FileDialog
On Error GoTo GetDateiname_Error
Set f = Application.FileDialog(msoFileDialogFilePicker)
With f
    .Title = "Mein Dialog"                    'Fenstertitel
    .AllowMultiSelect = False                 'Nur eine Datei auswählbar
    .ButtonName = "Auswählen"                 'Button Beschriftung
    .Filters.Clear                            'erst alle Filter löschen
    '.Filters.Add "Excel-Dateien", "*.xl*"     'dann eigene anlegen
    '.Filters.Add "Word-Dateien", "*.do*"
    .Filters.Add "Access-Dateien", "*.mdb; *.accdb"
    .FilterIndex = 2                          'einen Filter vorselektieren
    .InitialFileName = strInitialFileName                 'Startverzeichnis
    .Show
End With

If f.SelectedItems.Count > 0 Then
    GetDateiname = f.SelectedItems(1)
Else
    GetDateiname = ""
End If
GetDateiname_Exit:
Set f = Nothing
Exit Function
GetDateiname_Error:
MsgBox Err.Number & " " & Err.Description, vbOKOnly, "Fehler"
GoTo GetDateiname_Exit
End Function

First Part B

Public Function ConnectDB() As Boolean
On Error GoTo ConnectDatabase_Err
Dim strFilePath As String
Dim TD As DAO.TableDef
Dim NTD As DAO.TableDef
Dim DB As DAO.Database
Dim NDB As DAO.Database
Dim TDExist As Boolean
Set DB = CurrentDb

strFilePath = GetDateiname(Application.CurrentProject.Path)

If strFilePath <> "" Then

Set NDB = OpenDatabase(strFilePath)
    For Each TD In DB.TableDefs
        If TD.Connect <> "" Then
            TDExist = False
            For Each NTD In NDB.TableDefs
                If TD.Name = NTD.Name Then
                    TDExist = True
                    Exit For
                End If
            Next NTD
        End If
    Next TD
    If Not TDExist Then
        GoTo ConnectDatabase_Err
    End If
    strFilePath = "MS Access;PWD=Nelke;DATABASE=" & strFilePath
    For Each TD In DB.TableDefs
        If TD.Connect <> "" Then
            TD.Connect = strFilePath
            TD.RefreshLink
        End If
    Next TD
    ConnectDB = True
Else
    ConnectDB = False
End If
NDB.Close
Set NDB = Nothing
Set NTD = Nothing

ConnectDatabase_Res:
Set DB = Nothing
Set TD = Nothing

Exit Function
ConnectDatabase_Err:
ConnectDB = False
GoTo ConnectDatabase_Res:
End Function

'First Part C

'control  the DB is a Connected DB

Public Function isDBConnected() As Boolean
On Error GoTo isDBConnected_Error
Dim DB As DAO.Database
Dim TD As DAO.TableDef
Dim RS As DAO.Recordset
Dim strTemp As String
Set DB = CurrentDb
'hier erfolgt auch die fehlerüberprüfung wenn es die falsche db ist geht db.openrecordset in einen error
For Each TD In DB.TableDefs
    If TD.Attributes = dbAttachedTable Then
        Set RS = DB.OpenRecordset("SELECT * FROM " & TD.Name)
    End If
Next TD
isDBConnected = True

isDBConnected_Exit:
If Not RS Is Nothing Then RS.Close
Set DB = Nothing
Set TD = Nothing
Set RS = Nothing
Exit Function
isDBConnected_Error:
isDBConnected = False
'MsgBox Err.Number & " " & Err.Description, vbOKOnly, "Fehler"
GoTo isDBConnected_Exit
End Function

'Second Part for the Form

Private Sub BtnOpen_Click()
On Error GoTo BtnOpen_Click_Error
If ConnectDB = False Then
    MsgBox "Verbindung fehlgeschlagen", vbOKOnly + vbCritical, "Fehler bim offnen der Datei"
    Exit Sub
End If

Application.Echo False
DoCmd.Hourglass True
Forms!Navigationsformular!Navigationsunterformular.Form.Refresh
Forms!Navigationsformular!Navigationsunterformular!UFrmKasse.Form.Refresh
BtnOpen_Click_Resume:
Application.Echo True
DoCmd.Hourglass False
Exit Sub
BtnOpen_Click_Error:
MsgBox Err.Number & " " & Err.Description, vbCritical + vbOKOnly, "Fehler!"
GoTo BtnOpen_Click_Resume
End Sub