Problem i flerbruger løsning med FE/BE
Hej eksperter.Jeg har en DB, som er delt i FE/BE, begge som .MDB filer.
Der er en BE på en fælles server, hver bruger (to stk.) har sin egen FE.
Når jeg starter DB på maskine nr. 2 sker der ikke mere indtil jeg lukker på maskine 1. Dette mener jeg skyldes den kode jeg kører som kontrollerer om tabellerne er linket korrekt, og evt. opdaterer links. Der er i hvert fald ingen problemer når jeg slår denne fuktion fra.
Den kode jeg kører til opdatering af tabeller er indsat herunder.
Nogen der har en ide om hvad der er galt?
Jeg vil selv tro det er omkring .connect, men jeg er ikke helt skarp på dette område.
Det er umiddelbart kun de to første funktioner som er interressante, resten er små hjælpe funktioner.
Jeg kører Access 2007/2007.
Takker for hjælpen.
Function connect()
On Error Resume Next
Dim strFileAndPath As String
Dim db As DAO.Database
Dim tdef As DAO.TableDef
Dim foundfile As Boolean
foundfile = False
'Dim db As DAO.Database, xdb As Database
'Dim rs As DAO.Recordset
'Dim tmptable As TableDef
'Dim path As String, mdb As String, Filnavn As String
'Dim n As Integer, mdbOK As Boolean
'Dim filter As String, Felt As Variant
strFileAndPath = GetBackend 'find backend
If Dir(strFileAndPath) = "" Then 'der er problemer, DB ikke hvor den var sidst, fortsæt
strFileAndPath = FindNewFileAndPath(strFileAndPath) 'find fil
foundfile = True
Set db = CurrentDb
For n = 0 To db.TableDefs.Count - 1 ' test hver eneste tabel-link
'If Len(tdef.connect) > 0 Then
If Left(db.TableDefs(n).connect, 9) = "MS Access" Then
'MsgBox Err
db.TableDefs(n).connect = "MS Access;PWD=" & backend_PW & ";DATABASE=" & strFileAndPath
'MsgBox Err
DCount "*", db.TableDefs(n).name
'MsgBox db.TableDefs(n).name
'MsgBox Err
If Err <> 0 Then 'Problem, ingen forbindelse for den pågældende tabel, spørg efter ny fil
Err.Clear
'MsgBox strFileAndPath
strFileAndPath = FindNewFileAndPath(strFileAndPath) 'find fil
foundfile = True
End If
If Err <> 0 Then
MsgBox "hmm"
RefreshLinks = False
DoCmd.Hourglass False
Err.Clear
Exit Function
End If
End If
If foundfile = True Then
Exit For 'test kun indtil en tabel er fundet, og ext løkke, kør så connect på alle tabeller - to bad hvis der så mangler en!
End If
Next n
Else 'filen fandtes gør intet
'strFileAndPath = FindNewFileAndPath(strFileAndPath) 'find fil
End If
AttachAll (strFileAndPath)
End Function
Function AttachAll(strFileAndPath As String)
'Funktion til at linke alle tabeller til den ny-valgte DB BE-fil.
On Error GoTo err_handler
Dim db As DAO.Database
Dim tdef As DAO.TableDef
If Dir(strFileAndPath) <> "" Then
Set db = CurrentDb
For Each tdef In db.TableDefs
If Len(tdef.connect) > 0 Then
tdef.connect = "MS Access;PWD=" & backend_PW & ";DATABASE=" & strFileAndPath
Err = 0
'On Error Resume Next
tdef.RefreshLink
If Err <> 0 Then
RefreshLinks = False
DoCmd.Hourglass False
Exit Function
End If
End If
Next tdef
End If
Exit Function
err_handler:
MsgBox Err, vbCritical, "Fejl"
Exit Function
End Function
Function FindNewFileAndPath(strFileAndPath As String) As String
Dim dlg As New CommonDialog
'<<----Åbn Commondialog-boksen---->>
dlg.filter = "Access databaser" & vbNullChar & "*.mdb;*.mda;*.mde;*.mdw" & vbNullChar & "Alle filer" & vbNullChar & "*.*" & vbNullChar
dlg.DialogTitle = "Angiv ny placering af " & ExtractFileName(strFileAndPath) & "..."
dlg.InitDir = GetBackend
dlg.ShowOpen
FindNewFileAndPath = dlg.Filename
If IsNull(strFileAndPath) Or strFileAndPath = "" Then
Exit Function
End If
End Function
Function GetBackend() As String
' Find stien til backend ved at find den første sammenkædet tabel og kigge på dens .Connect-property
On Error Resume Next
Dim tdef As TableDef
Dim db As Database
Dim myval
Set db = CurrentDb
Set tdef = db.TableDefs(DFirst("Name", "msysobjects", "Type = 6"))
GetBackend = tdef.connect
myval = InStr(GetBackend, "DATABASE")
GetBackend = Mid(GetBackend, myval + 9)
'MsgBox GetBackend
End Function
Function ExtractFileName(ConnectString As String) As String
Dim path As String
path = ConnectString
Do Until Right(path, 1) = "\"
path = Left(path, Len(path) - 1)
Loop
ExtractFileName = Right(ConnectString, Len(ConnectString) - Len(path))
End Function
Function Extractpath(Streng As String) As String
Do Until Right(Streng, 1) = "\"
Streng = Left(Streng, Len(Streng) - 1)
Loop
Extractpath = Streng
End Function