title image


Smiley Re: Tabellen aus anderer DB einfügen/einbinden
Moin,das nachfolgende Beispiel prüft, ob die Verknüpfung zu bestimmten Tabellen noch besteht. Wenn z.B. die Daten-Datenbank woanders steht oder der Programmteil noch gänzlich ohne Verknüpfungen ist, legt die Routine los.Achtung: Viel Text!Diese Funktion wird beim Start der DB abgenudelt:Function EinbindenTabelle() Dim strDir As String Dim strDB As String Dim x As Variant dim d_version as string Dim strtabname As String DoCmd.Hourglass True d_version = Name der Anwendung, eigentlich eine globale CONST-Variable strDB = Datenbankname x = SysCmd(SYSCMD_INITMETER, "Überprüfen und Einbinden der " & d_version & "-Tabellen", 6) If Not TestTabelle("tab1", strDB) Then strtabname = "tab1" If Not TabelleNeuEinbinden(strDB, "tab1") Then GoTo err_Einbindung End If x = SysCmd(SYSCMD_UPDATEMETER, 1) If Not TestTabelle("tab2", strDB) Then strtabname = "tab2" If Not TabelleNeuEinbinden(strDB, "tab2") Then GoTo err_Einbindung End If x = SysCmd(SYSCMD_UPDATEMETER, 2) If Not TestTabelle("tab3", strDB) Then strtabname = "tab3" If Not TabelleNeuEinbinden(strDB, "tab3") Then GoTo err_Einbindung End Ifusw...In der nächsten Funktion wird geprüft, ob die Tabelle lebt:Function TestTabelle(strTableName As String, strdbname As String) As Integer Dim wrkWorkspace As Workspace Dim dbTemp As Database Dim i As Integer, j As Integer Static fFirst As Integer Set wrkWorkspace = DBEngine.Workspaces(0) Set dbTemp = wrkWorkspace.Databases(0) On Error GoTo err_Neu For i = 0 To dbTemp.TableDefs.Count - 1 If dbTemp.TableDefs(i).Name = strTableName Then TestTabelle = True j = i dbTemp.TableDefs(i).RefreshLink Exit Function End If Next i TestTabelle = False Exit Functionerr_Neu: If fFirst = 0 Then If Len(Dir(strdbname)) > 0 Then sz_database = ";DATABASE=" + strdbname Else sz_database = ";DATABASE=" + HoleDatenbank(strdbname)HoleDatenbank sucht sich die Datenbanken (dieses Programm verwendet mehrere) von irgendeinem Laufwerk End If fFirst = 1 End If DoCmd.Hourglass False dbTemp.TableDefs(j).Connect = sz_database DoCmd.Hourglass True dbTemp.TableDefs(j).RefreshLink Resume NextEnd FunctionNun muß nur noch eingebunden werden:Function TabelleNeuEinbinden(strFileName As String, strTableName As String) As Integer Dim wrkWorkspace As Workspace, dbDatabase As Database Dim tblTable As TableDef Dim i As Integer Dim strFname As String On Error GoTo err_TabelleNeuEinbinden Set wrkWorkspace = DBEngine.Workspaces(0) ' Standard-Arbeitsbereich ermitteln. Set dbDatabase = wrkWorkspace.Databases(0) ' Aktuelle Datenbank ermitteln. Set tblTable = dbDatabase.CreateTableDef(strTableName) If sz_database = "" Then DoCmd.Hourglass False If Len(Dir(strFileName)) > 0 Then sz_database = strFileName Else sz_database = HoleDatenbank(strFileName) End If DoCmd.Hourglass True If sz_database = "" Then TabelleNeuEinbinden = False Exit Function End If End If strFname = ";DATABASE=" & sz_database tblTable.Connect = strFname tblTable.SourceTableName = strTableName dbDatabase.TableDefs.Append tblTable ' Tabelle einbinden. TabelleNeuEinbinden = True sz_database = "" Exit Functionerr_TabelleNeuEinbinden: MsgBox Error$ TabelleNeuEinbinden = False DoCmd.Quit Resume NextEnd FunctionWenn du die Suche nach der Datenbankdatei automatisieren willst, dann kannst du noch dieses Code verwenden:In den allgemeinen Deklarationen:Public g_letzteslw As StringDim sz_database As StringGlobal Const DBDAT = "xxx_dat.mdb"Global Const DBKAT = "xxx_kat.mdb"Global Const DBPRG = "xxx_prg.mdb"Global Const MAX_PATH = 260Declare Function SearchTreeForFile Lib "imagehlp.dll" _(ByVal sRootPath As String, _ ByVal InputPathName As String, _ ByVal OutputPathBuffer As String) As BooleanHier nun die Funktion zum Suchen der Datenbankdatei:Function HoleDatenbank(strFileName As String) As String ' Suchen der Datenbanken Dim sResult As String Dim x As Byte Dim v_ant As Byte Dim sDrive2Scan As String, sFile2Find As String Dim getfilelocation As String sFile2Find = strFileName sResult = Space(MAX_PATH) ' Versuchen wir es zuerst mit der letzten Einstellung If IsNull(g_letzteslw) Or IsEmpty(g_letzteslw) Then g_letzteslw = "c" Else sDrive2Scan = g_letzteslw & ":\" If SearchTreeForFile(sDrive2Scan, sFile2Find, sResult) Then getfilelocation = Left(sResult, InStr(sResult, vbNullChar) - 1) GoTo gefunden End If End If ' 1. Chance mit Eingabe des Buchstabens Dim v_lw As String Dim v_mel As String v_mel = "Geben Sie bitte den Laufwerksbuchstaben an," & Chr(13) v_mel = v_mel & "auf dem sich die Datenbank " & Chr(13) v_mel = v_mel & strFileName & " befindet." & Chr(13) & Chr(13) v_mel = v_mel & "Es genügt nur der Buchstabe, den Zusatz ':\' lassen Sie bitte weg." v_lw = InputBox(v_mel, "Programmname - Laufwerksauswahl", g_letzteslw) If v_lw = "" Or IsNull(v_lw) Or IsEmpty(v_lw) Then Else sDrive2Scan = v_lw & ":\" If SearchTreeForFile(sDrive2Scan, sFile2Find, sResult) Then getfilelocation = Left(sResult, InStr(sResult, vbNullChar) - 1) g_letzteslw = Mid(sDrive2Scan, 1, 1) GoTo gefunden End If End If ' Chance nicht genutzt, jetzt beginnt die Ochsentour DoCmd.Hourglass True v_mel = "Es werden jetzt alle angeschlossenen Laufwerke überprüft." & Chr(13) v_mel = v_mel & "Dieser Vorgang kann einige Minuten daueren." MsgBox v_mel, 48, "Programmname - Hinweis" For x = 1 To 27 Step 1 Select Case x Case 1 sDrive2Scan = "a:\" Case 2 sDrive2Scan = "b:\" Case 3 sDrive2Scan = "c:\" Case 4 sDrive2Scan = "d:\" Case 5 sDrive2Scan = "e:\" Case 6 sDrive2Scan = "f:\" Case 7 sDrive2Scan = "g:\" Case 8 sDrive2Scan = "h:\" Case 9 sDrive2Scan = "i:\" Case 10 sDrive2Scan = "j:\" Case 11 sDrive2Scan = "k:\" Case 12 sDrive2Scan = "l:\" Case 13 sDrive2Scan = "m:\" Case 14 sDrive2Scan = "n:\" Case 15 sDrive2Scan = "o:\" Case 16 sDrive2Scan = "p:\" Case 17 sDrive2Scan = "q:\" Case 18 sDrive2Scan = "r:\" Case 19 sDrive2Scan = "s:\" Case 20 sDrive2Scan = "t:\" Case 21 sDrive2Scan = "u:\" Case 22 sDrive2Scan = "v:\" Case 23 sDrive2Scan = "w:\" Case 24 sDrive2Scan = "x:\" Case 25 sDrive2Scan = "y:\" Case 26 sDrive2Scan = "z:\" Case Else sDrive2Scan = "c:\" End Select If SearchTreeForFile(sDrive2Scan, sFile2Find, sResult) Then getfilelocation = Left(sResult, InStr(sResult, vbNullChar) - 1) g_letzteslw = Mid(sDrive2Scan, 1, 1) GoTo gefunden End If Next x DoCmd.Hourglass False Dim meldg As String meldg = "Die Datenbank " & strFileName & " wurde nicht gefunden." & Chr(13) meldg = meldg & "Stellen Sie sicher, dass die Datenbank sich auf einem angeschlossenen Laufwerk" & Chr(13) meldg = meldg & "befindet und starten Sie dann das Programm erneut!" MsgBox meldg, 48, "Programmname - Fehlermeldung" DoCmd.Quit acQuitSaveNonegefunden: DoCmd.Hourglass False HoleDatenbank = getfilelocationEnd FunctionGood luck.Jörg

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: