opstarten duurt lang (connectie backend frontend)

[allard1977]

Hallo,

mijn database heeft een back-end en een Front-end. nu gebruik ik de volgende vba code om ze met elkaar te verbinden. maar nu ik een password op de back-end heb gezet duurt het lang voor dat alles begint. kan zelfs zijn dat hij aangeeft not responding.
dit is de module die ik gebruik.

Option Compare Database
Option Explicit
Public Const cPassword As String = "08#@NS09*"

Function fRefreshLinks() As Boolean
Dim strMsg As String, collTbls As Collection
Dim i As Integer, strDBPath As String, strTbl As String
Dim dbCurr As Database, dbLink As Database
Dim tdfLocal As TableDef
Dim varRet As Variant
Dim strNewPath As String

Const cERR_USERCANCEL = vbObjectError + 1000
Const cERR_NOREMOTETABLE = vbObjectError + 2000

    On Local Error GoTo fRefreshLinks_Err
    
       
    Set collTbls = fGetLinkedTables
 
    Set dbCurr = CurrentDb

    For i = collTbls.Count To 1 Step -1
        strDBPath = fParsePath(collTbls(i))
        strTbl = fParseTable(collTbls(i))
        varRet = SysCmd(acSysCmdSetStatus, "Now linking '" & strTbl & "'....")
        If Left$(strDBPath, 4) = "ODBC" Then
        Else
            If strNewPath <> vbNullString Then
               strDBPath = strNewPath
            Else
              If Len(Dir(strDBPath)) = 0 Then
                 strDBPath = fGetMDBName("'" & strDBPath & "' not found.")
                    If strDBPath = vbNullString Then
                       Err.Raise cERR_USERCANCEL
                    End If
               End If
            End If
            Set dbLink = DBEngine(0).OpenDatabase(strDBPath, False, True, ";pwd=" & cPassword)

            strTbl = fParseTable(collTbls(i))
            If fIsRemoteTable(dbLink, strTbl) Then
                Set tdfLocal = dbCurr.TableDefs(strTbl)
                With tdfLocal
                    .Connect = ";Database=" & strDBPath & ";PWD=" & cPassword
                    .RefreshLink
                    collTbls.Remove (.Name)
                End With
            Else
                Err.Raise cERR_NOREMOTETABLE
            End If
        End If
    Next
    fRefreshLinks = True
    varRet = SysCmd(acSysCmdClearStatus)
    MsgBox "All Access tables were successfully reconnected.", _
            vbInformation + vbOKOnly, _
            "Success"

fRefreshLinks_End:
    Set collTbls = Nothing
    Set tdfLocal = Nothing
    Set dbLink = Nothing
    Set dbCurr = Nothing
    Exit Function
fRefreshLinks_Err:
    fRefreshLinks = False
    Select Case Err
        Case 3059:

        Case cERR_USERCANCEL:
            MsgBox "No Database was specified, couldn't link tables.", _
                    vbCritical + vbOKOnly, _
                    "Error in refreshing links."
            Resume fRefreshLinks_End
        Case cERR_NOREMOTETABLE:
            MsgBox "Table '" & strTbl & "' was not found in the database" & _
                    vbCrLf & dbLink.Name & ". Couldn't refresh links", _
                    vbCritical + vbOKOnly, _
                    "Error in refreshing links."
            Resume fRefreshLinks_End
        Case Else:
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
            strMsg = strMsg & "Description: " & Err.Description & vbCrLf
            strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
            MsgBox strMsg, vbOKOnly + vbCritical, "Error"
            Resume fRefreshLinks_End
    End Select
End Function
Function fIsRemoteTable(dbRemote As Database, strTbl As String) As Boolean
Dim tdf As TableDef
    On Error Resume Next
    Set tdf = dbRemote.TableDefs(strTbl)
    fIsRemoteTable = (Err = 0)
    Set tdf = Nothing
End Function

Function fGetMDBName(strIn As String) As String
Dim strfilter As String

    strfilter = ahtAddFilterItem(strfilter, _
                    "Access Database(*.accdb;*.accdr) ", _
                    "*.ACCDB; *.ACCDR")
    strfilter = ahtAddFilterItem(strfilter, _
                    "All Files (*.*)", _
                    "*.*")

    fGetMDBName = ahtCommonFileOpenSave(Filter:=strfilter, _
                                OpenFile:=True, _
                                DialogTitle:=strIn, _
                                Flags:=ahtOFN_HIDEREADONLY)
End Function

Function fGetLinkedTables() As Collection
    Dim collTables As New Collection
    Dim tdf As TableDef, db As Database
    Set db = CurrentDb
    db.TableDefs.Refresh
    For Each tdf In db.TableDefs
        With tdf
            If Len(.Connect) > 0 Then
                If Left$(.Connect, 4) = "ODBC" Then
                Else
                    collTables.Add Item:=.Name & .Connect, Key:=.Name
                End If
            End If
        End With
    Next
    Set fGetLinkedTables = collTables
    Set collTables = Nothing
    Set tdf = Nothing
    Set db = Nothing
End Function

Function fParsePath(strIn As String) As String
    If Left$(strIn, 4) <> "ODBC" Then
        fParsePath = Right(strIn, Len(strIn) _
                        - (InStr(1, strIn, "DATABASE=") + 8))
    Else
        fParsePath = strIn
    End If
End Function

Function fParseTable(strIn As String) As String
If InStr(strIn, "MS A") > 1 Then
strIn = Left(strIn, (InStr(strIn, "MS A") - 1))
fParseTable = strIn
End If
If InStr(1, strIn, ";") > 1 Then
fParseTable = Left$(strIn, InStr(1, strIn, ";") - 1)
End If
End Function

alvast heel erg bedankt
Allard

 

[JohanRVT]

Waarom moet je de moeite doen om "actief" je DB's met elkaar te verbinden? Voor zover ik weet gebeurd dat toch steeds automatisch bij het herstartten eens je de koppeling eenmaal werkend hebt gemaakt. Je krijgt pas een melding als het niet lukt en dan open je via een knopje (in mijn voorbeeldje CmbKoppelen genoemd) gewoon koppelingsbeheer.

Private Sub CmbKoppelen_Click()
DoCmd.RunCommand acCmdLinkedTableManager
End Sub

Misschien omdat windows de netwerkverbinding niet automatisch maakt bij herstarten? Dat kun je in windows ook regelen bij netwerkbeheer.