Re-link frontend to backend error (1 Viewer)

ebbsamsung

Registered User.
Local time
Yesterday, 17:11
Joined
May 22, 2014
Messages
19
Dear Experts,

Good day!

I found a code to re-link frontend to backend exactly as I want to happen when the DB is open. But when I call the function there is an error occur. Is there any thing that I need to change to work this out or am i wrongly put this in my start up form or wrongly calling the function?


The code in my startup form:
Code:
Call fRefreshLinks
Here is the code from Dev Ashish I adapted AS IS:

Code:
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

    If MsgBox("Are you sure you want to reconnect all Access tables?", _
            vbQuestion + vbYesNo, "Please confirm...") = vbNo Then Err.Raise cERR_USERCANCEL

    'First get all linked tables in a collection
    Set collTbls = fGetLinkedTables

    'now link all of them
    Set dbCurr = CurrentDb

    strMsg = "Do you wish to specify a different path for the Access Tables?"
    
    If MsgBox(strMsg, vbQuestion + vbYesNo, "Alternate data source...") = vbYes Then
        strNewPath = fGetMDBName("Please select a new datasource")
    Else
        strNewPath = vbNullString
    End If

    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
            'ODBC Tables
            'ODBC Tables handled separately
           ' Set tdfLocal = dbCurr.TableDefs(strTbl)
           ' With tdfLocal
           '     .Connect = pcCONNECT
           '     .RefreshLink
           '     collTbls.Remove (strTbl)
           ' End With
        Else
            If strNewPath <> vbNullString Then
                'Try this first
                strDBPath = strNewPath
            Else
                If Len(Dir(strDBPath)) = 0 Then
                    'File Doesn't Exist, call GetOpenFileName
                    strDBPath = fGetMDBName("'" & strDBPath & "' not found.")
                    If strDBPath = vbNullString Then
                        'user pressed cancel
                        Err.Raise cERR_USERCANCEL
                    End If
                End If
            End If

            'backend database exists
            'putting it here since we could have
            'tables from multiple sources
            Set dbLink = DBEngine(0).OpenDatabase(strDBPath)

            'check to see if the table is present in dbLink
            strTbl = fParseTable(collTbls(i))
            If fIsRemoteTable(dbLink, strTbl) Then
                'everything's ok, reconnect
                Set tdfLocal = dbCurr.TableDefs(strTbl)
                With tdfLocal
                    .Connect = ";Database=" & strDBPath
                    .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
'Calls GetOpenFileName dialog
Dim strFilter As String

    strFilter = ahtAddFilterItem(strFilter, _
                    "Access Database(*.mdb;*.mda;*.mde;*.mdw) ", _
                    "*.mdb; *.mda; *.mde; *.mdw")
    strFilter = ahtAddFilterItem(strFilter, _
                    "All Files (*.*)", _
                    "*.*")

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

Function fGetLinkedTables() As Collection
'Returns all linked tables
    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
                '    collTables.Add Item:=.Name & ";" & .Connect, KEY:=.Name
                'ODBC Reconnect handled separately
                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
    fParseTable = Left$(strIn, InStr(1, strIn, ";") - 1)
End Function
 

Attachments

  • ErrorRelinkBE.JPG
    ErrorRelinkBE.JPG
    55.3 KB · Views: 105

Cronk

Registered User.
Local time
Today, 11:11
Joined
Jul 4, 2013
Messages
2,770
As the error message indicates, the function highlighted is missing. You need to add it.
 

ebbsamsung

Registered User.
Local time
Yesterday, 17:11
Joined
May 22, 2014
Messages
19
Sir Cronk,

Thanks for the reply, could you please guide how do i make it? I am a novice in VBA actually.

Thank you!
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 08:11
Joined
May 7, 2009
Messages
19,169
replace the function fGetMDBName with this one.
make sure you add Reference (in VBA, Tool-Reference) to Microsoft Office X.XX Object Library

Code:
Public Function fGetMDBName(Optional strFileName As String, _
    Optional ByVal strWindowTitle As String = "Select a database file") As String

    Dim fd As Office.FileDialog
    
    'Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    With fd
        .Title = strWindowTitle
	.Filters.Clear
        .Filters.Add "All files", "*.*", 1
        .Filters.Add "Access Database", "*.mdb;*.mda;*.mde;*.accdb;*.accde", 2
        .AllowMultiSelect = False
        If .Show = -1 Then
            fGetMDBName= (.SelectedItems(1))
        Else
            fGetMDBName= vbNullString
        End If
    End With
    Set fd = Nothing
End Function
 
  • Like
Reactions: Rx_

ebbsamsung

Registered User.
Local time
Yesterday, 17:11
Joined
May 22, 2014
Messages
19
Sir Arnelgp,

Thank you so much for helping this code to make it right, Its actually working but the problem now another error message coming pointing to another function. Could you please see it for me the screenshot i attached?

Thank you
 

Attachments

  • Error2.JPG
    Error2.JPG
    32.5 KB · Views: 95
  • Like
Reactions: Rx_

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 08:11
Joined
May 7, 2009
Messages
19,169
You are missing the DeleteLink function.
Copy again the original code and just replace fGetMDBName function.
 

ebbsamsung

Registered User.
Local time
Yesterday, 17:11
Joined
May 22, 2014
Messages
19
Sir Arnelgp,

Thank you very much for that piece of code, it helps me alot...
Its running now, I just miss-look the end function. I deleted it already and its running fine now.

Thank you once again sir Arnelgp.

:)
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 08:11
Joined
May 7, 2009
Messages
19,169
Youre welcome.
 

Users who are viewing this thread

Top Bottom