Neue Backends wählen durch Knopfdruck

[MaggieMay]

Hast du das dort genauso falsch geschrieben wie hier oder was ist der Grund?
Die Fehlermeldung solltest du uns am besten sofort und ohne extra Nachfrage dazu liefern.

dann habe ich den Einbinde-Code falsch verstanden

Was meinst du wohl was diese Zeilen aus dem Einbinde-Code bewirken:

Code [Auswählen] Erweitern

            DoCmd.DeleteObject acTable, rs!tabName
            DoCmd.TransferDatabase acLink, "Microsoft Access", _
                         bePath & "*.accdb", strForeignName, strtabName

[Churian]

Guten Morgen,

wir haben ja schon festgestellt das der ursprüngliche Einbinde-Code Schwachsinn ist. Ich verwende den auch gar nicht mehr.
Ich dachte deine letzter Post bezieht sich auf meine neuere Idee das über den Namensabgleich umzusetzten.

Ich schreibe nochmal meinen kompletten Code für den Button hier hin.

Code [Auswählen] Erweitern

Private Sub cmd_Action_Click()
Call DelTable
Call OpenFile
End Sub



Function OpenFile() As String
    Dim fso As FileDialog
    Dim Datei As String
    Dim Auswahl As Variant
   
    Set fso = Application.FileDialog(msoFileDialogFilePicker)   
    fso.Filters.Add "Datenbank", "*.mdb,*.accdb,*.mde", 1     
    fso.Title = "Office Lösung Dateidialog"                 
    fso.ButtonName = "Backendwahl"                           
    fso.InitialFileName = "G:\Service\Probedatenbank\Backends" 
    fso.InitialView = msoFileDialogViewLargeIcons           
    If fso.Show = -1 Then                                     
        For Each Auswahl In fso.SelectedItems               
             Datei = Auswahl
        Next Auswahl
    End If
    OpenFile = Datei
    Set fso = Nothing 
    Call LinkTables
End Function


Sub DelTable()
     Dim db As DAO.Database
    Dim i As Integer
   
    Set db = CurrentDb
    For i = db.TableDefs.Count - 1 To 0 Step -1
        'Debug.Print db.TableDefs(i).Name, db.TableDefs(i).Attributes
        'If db.TableDefs(i).Attributes = 0 Then
            If Left(db.TableDefs(i).Name, 4) = "tbl_" Then
                Debug.Print db.TableDefs(i).Name
                DoCmd.DeleteObject acTable, db.TableDefs(i).Name
            End If
        'End If
    Next i
End Sub
   


Sub LinkTables()
    ' Verweis auf Microsof DAO
    Dim db As DAO.Database
    Dim i As Integer
   
    Set db = Auswahl

    For i = db.TableDefs.Count - 1 To 0 Step -1
        'Debug.Print db.TableDefs(i).Name, db.TableDefs(i).Attributes
        'If db.TableDefs(i).Attributes = 0 Then
            If Left(db.TableDefs(i).Name, 4) = "tbl_" Then
                Debug.Print db.TableDefs(i).Name
                DoCmd.TransfereDatabase acTable, db.TableDefs(i).Name
            End If
        'End If
    Next i
End Sub



Grüße

[MaggieMay]

Hi,

so könnte es was werden:

Code [Auswählen] Erweitern

' Verweis auf Microsof DAO wird benötigt
' Verweis auf Office-Bibliothek wird benötigt

Private Sub cmd_Action_Click()
    Dim strDateiname As String
    Call DelTables
    strDateiname = OpenFile
    Call LinkTables(strDateiname)
End Sub

Function OpenFile() As String
    Dim fso As FileDialog
    Dim Datei As String
   
    Set fso = Application.FileDialog(msoFileDialogFilePicker)
    With fso
        .Filters.Add "Datenbank", "*.mdb,*.accdb,*.mde", 1
        .AllowMultiSelect = False
        .title = "Office Lösung Dateidialog"
        .ButtonName = "Backendwahl"
        .InitialFileName = "G:\Service\Probedatenbank\Backends"
        .InitialView = msoFileDialogViewLargeIcons
        If .Show = -1 Then
            Datei = .SelectedItems(1)
        End If
    End With
    OpenFile = Datei
    Set fso = Nothing
End Function

Sub DelTables()
    Dim db As DAO.Database
    Dim i As Integer
   
    Set db = CurrentDB
    For i = db.TableDefs.Count - 1 To 0 Step -1
        'Debug.Print db.TableDefs(i).Name, db.TableDefs(i).Attributes
        If Left(db.TableDefs(i).Name, 4) = "tbl_" Then
            Debug.Print db.TableDefs(i).Name
            DoCmd.DeleteObject acTable, db.TableDefs(i).Name
        End If
    Next i
End Sub

Sub LinkTables(strBE)
    Dim db As DAO.Database, td As DAO.TableDef
    Dim i As Integer
    Set db = DBEngine.Workspaces(0).OpenDatabase(strBE)
    For Each td In db.TableDefs
        If Left(db.TableDefs(i).Name, 4) = "tbl_" Then
            ' Debug.Print db.TableDefs(i).Name
            DoCmd.TransferDatabase acLink, "Microsoft Access", strBE, acTable, db.TableDefs(i).Name
        End If
    Next
    db.Close
    Set db = Nothing
End Sub


[Churian]

Hey Maggie,

vorab erstmal danke für die Mühe. Ich hab den Code mal ausprobiert und er funktioniert.

Ich habe das zwischenzeitlich aber auch "selber" hin bekommen oder besser ich habe eine Datenbank gefunden die eine solche Funktion bereits hat.

In der Datenbank gab es eine Tabelle in der der Dateipfad des Backends hinterlegt ist und ein Modul und einen Button der alles auslöst.

Tabellenname: sys

Code des Knopfes:

Code [Auswählen] Erweitern

Option Compare Database
Option Explicit

Private Sub neuButton_Click()
Dim dbx As DAO.Database
Dim tb As DAO.TableDef
Dim sBEpfad As String
       
    sBEpfad = dateioeffnen(Application.CurrentProject.Path, "BackEnd Datenbank öffnen")
    If sBEpfad <> "" And (Right(sBEpfad, 4) = ".mdb" Or Right(sBEpfad, 6) = ".accdb") Then
        Set dbx = DBEngine.Workspaces(0).OpenDatabase(sBEpfad)
        db_aendern (sBEpfad)
        For Each tb In dbx.TableDefs()
            If InStr(1, tb.Name, "MSys") = 0 Then tabcheck tb.Name, sBEpfad
        Next
    End If
   
End Sub

Code des Moduls:

Code [Auswählen] Erweitern

Option Compare Database
Option Explicit

Function init()
Dim pfad As String
Dim dbx As DAO.Database
Dim rs As DAO.Recordset
Dim t As DAO.TableDef
Dim sBEPath As String
On Error GoTo init_err

    Set rs = CurrentDb.OpenRecordset("sys")
   
    If rs.EOF Then
        MsgBox "Kein Datensatz in der Tabelle 'sys'", vbCritical, "Hoppla"
        rs.AddNew
        rs!dbnam = "dummy"
        rs.Update
    End If
   
    Do While Not rs.EOF
   
        sBEPath = rs!dbnam
        If InStr(1, sBEPath, "\") = 0 Then
            pfad = Application.CurrentProject.Path & "\" & sBEPath
        Else
            pfad = sBEPath
        End If
       
        Set dbx = DBEngine.Workspaces(0).OpenDatabase(pfad)
   
        For Each t In dbx.TableDefs()
            If InStr(1, t.Name, "MSys") = 0 Then tabcheck t.Name, pfad
        Next

        rs.MoveNext
   
    Loop
    rs.Close

init_exit:
    Set dbx = Nothing
    On Error GoTo 0
    Exit Function
   
init_err:
    If Err.Number = 3024 Or Err.Number = 3044 Or Err.Number = 3043 Then
        pfad = dateioeffnen(Application.CurrentProject.Path, "BackEnd Datenbank öffnen")
        If pfad <> "" Then
            db_aendern (pfad)
        Else
            Application.Quit
        End If
    ElseIf Err.Number = 3059 Then
        Application.Quit
    ElseIf Err.Number = 94 Then
        MsgBox "Kein Dateiname im Feld 'sys.dbname'", vbCritical, "Hoppla"
        rs.Edit
        rs!dbnam = "dummy"
        rs.Update
    ElseIf Err.Number = 3078 Then
        MsgBox "Keine Tabelle 'sys' vorhanden", vbCritical, "Hoppla"
        CurrentDb.Execute "SELECT 'dummy' AS dbnam INTO sys;"
    Else
        MsgBox "Fehler: " & Err.Number & " - " & Err.Description
        Stop
    End If
    Resume
   
End Function

Sub tabcheck(tabnam As String, quelle As String)
Dim rs As DAO.Recordset
On Error GoTo tabcheck_err
   
    Set rs = CurrentDb.OpenRecordset(tabnam)
    rs.Close
   
tabcheck_exit:
    On Error GoTo 0
    Exit Sub
   
tabcheck_err:
    If Err.Number = 3078 Then
        DoCmd.TransferDatabase acLink, "Microsoft Access", _
         quelle, acTable, tabnam, tabnam
    ElseIf Err.Number = 3024 Or Err.Number = 3044 Or Err.Number = 3043 Then
        CurrentDb.Execute "DROP TABLE [" & tabnam & "];"
    Else
        MsgBox "Fehler: " & Err.Number & " - " & Err.Description
        Stop
    End If
    Resume
End Sub

Sub db_aendern(p As String)
Dim t As DAO.TableDef
Dim rs As DAO.Recordset

    For Each t In CurrentDb.TableDefs()
        If t.Connect <> "" Then
            CurrentDb.Execute "DROP TABLE [" & t.Name & "];"
        End If
    Next
    Set rs = CurrentDb.OpenRecordset("sys")
    rs.MoveFirst
    rs.Edit
    rs!dbnam = p
    rs.Update
    rs.Close
End Sub

Function dateioeffnen(datnam As String, titel As String) As String

    With Application.FileDialog(1)
        .AllowMultiSelect = False
        .Title = titel
        .InitialFileName = datnam
       
        If .Show = -1 Then
            dateioeffnen = .SelectedItems(1)
        Else
            dateioeffnen = ""
        End If
    End With

End Function


Ich hoffe das hilft Leuten die ein ähnliches Problem haben.


Mit freundlichen Grüßen


Churian