Dev Ashish's fRefreshLinks with password error

[JayF]

Hi all,

I'm calling a slightly modified Dev Ashish's fRefreshLinks as part of handling an error on opening the switchboard if the backend linked tables are missing. It's Access 2007.

I found a two line tweak online to enable the function to handle passwords, however, after implementing this I'm running into a strange error where the variable strTbl is having "MS Access" appended to it. The exact error message I am getting is:

"Table 'tblTitlesMS Access' was not found in the database C:\Correct\Path\And\DB\Name.accdb. Couldn't refresh links" Note: strTbl = "tblTitlesMS Access")

The correct table name would be 'tblTitles'. There is no instance of "MS Access" in the code, so this must be coming from somewhere else. I suspect this code would be working if it wasn't for this mysterious excess Access

Following is the exact code I currently have. Hopefully somebody here is already familiar with it, I wouldn't expect anybody to digest it from scratch. I have emboldened my own tweaks as well as instances of strTbl - the offending variable - and the error handler being invoked.

I pretty much understand how the code works and follow the logic, but I don't know enough about the underlying processes in linking tables to pinpoint the cause of this.

Any ideas would be much appreciated.

Thanks,

Jay

'*************** Code Start ***************
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
Function fRefreshLinks(strPrompt As String) 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
Dim cPassword As String
 
Const cERR_USERCANCEL = vbObjectError + 1000
Const cERR_NOREMOTETABLE = vbObjectError + 2000
 
    On Local Error GoTo fRefreshLinks_Err
 
    'Prompt User
    If MsgBox(strPrompt, vbQuestion + vbYesNo, "Alternate data source...") = vbYes Then
        strNewPath = fGetMDBName("Please select a new datasource")
    Else
    Err.Raise cERR_USERCANCEL
    End If
 
    'Get Password
    cPassword = InputBox("Please enter your backend password:", "Enter Password.")
 
   'First get all linked tables in a collection
    Set collTbls = fGetLinkedTables
 
    'now link all of them
    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
            '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) ' Original
            Set dbLink = DBEngine(0).OpenDatabase(strDBPath, False, True, ";pwd =" & cPassword) ' With Password
'
            '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 ' Original
                    .Connect = ";Database=" & strDBPath & ";PWD=" & cPassword ' With Password
                    .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

[NeoPa]

Jay, you need to include some basic information here such as the line the error message occurs on. Otherwise this is a needle in a haystack situation. Please check out Before Posting (VBA or SQL) Code for some more instructns on what needs to be done prior to posting a question about included code.

[Mihail]

Your code looks good for me.
In your current database seems to exist (indeed) a table named tblTitlesMS Access.
I suspect that it is hidden (Don't ask me why :) ).
So, in order to debug, do the following:

Navigate to:
Office Button -> Access Options -> Current Database -> Navigation Options
and check all check boxes in Display Options area.
After that, in Navigation Pane, look for that table and remove it (if you find it).


Make a copy before !


@NeoPa
The code will not stop at this error.
Line #87 will raise the error and the error message is from line #114

[JayF]

Hi Mihail,

An existing table was my first thought, however even on enabling all options, no table by the name of "tblTitlesMS Access" exists. Is there some other way a tabledef could be hidden?

As you predicted, even on commenting out the "On Local Error..." line, the code doesn't throw an error until it reaches line 87. (I had previously tested this, but missed it from my post, apologies Neo).

On placing a debug dot in the Function fParseTable and bringing up strIn in a MsgBox displays:

tblTitlesMS Access;PWD=asdfzxcv;DATABASE=C:\Correct\Path\And\N ame.accdb

This would indeed point to a TableDef by that name existing. However, I have just placed the code...

Dim x as Integer
x = 1
For i = collTbls.Count To 1 Step -1
        If Left(collTbls(i), 9) = "tblTitles" Then
            i = i - x
        End If
 

...at the start of the For loop. I then tried assigning various numbers to x and the error is now the same, but with which ever table falls at that number, e.g. "tblStatusMS Access", "tblContactMS Access".

This would point to either a duplication of all tables with MS Access appended to them, or seemingly more likely, that strTbl is having MS Access appended to it before being passed to fParseTable.


Any thoughts?

Thanks again,

Jamie

[Mihail]

Is beyond my skill (or my working time) to fully debug your code.
Here is how I manage the "link" issue for a Front End database:

Public Function ReConnect(BackEndPath As String) As Boolean
    ReConnect = False
On Error GoTo ErrorHandler
If BackEndPath = "" Then Exit Function
 
Dim tbl As TableDef
Dim db As Database
'(Re)link current Front End database
    Set db = CurrentDb
    GoSub RelinkThisFE
 
    'All is Ok
    ReConnect = True
 
Ex:
Exit Function
 
RelinkThisFE:
    With db
        For Each tbl In .TableDefs
            If (tbl.Attributes And dbAttachedTable) Then 'This is a linked table
                With .TableDefs(tbl.Name)
                    .Connect = ";DATABASE=" & BackEndPath
                    Call .RefreshLink
                End With
            End If
        Next
        Call .Close
    End With
Return
 
ErrorHandler:
    MsgBox ("I think that you have wrong selected the back end database. Try again !")
    db.Close
    set db  = Nothing
    Resume Ex
End Function

[NeoPa]

I would trace through fGetLinkedTables(). I suspect it is creating your collection incorrectly, as it is based on the assumption that any .Connect string that doesn't start with "ODBC" must necessarily start with a ";". There is an .Attributes property that is a better test for that in my view (Check out the difference between dbAttachedTable and dbAttachedODBC).

[JayF]

Sure Mihail, I understand that. I was hoping it was something that would jump out and smack you in the face. Thanks for your solution. I'll have a play with it if I can't fix this one.

You inadvertently gave me a new lead. In unhiding the System objects you showed me the table MSysObjects which includes a Connect field showing "MS Access;PWD=asdfzxcv;". I'm going to play with the code with this in mind.


NeoPa, fGetLinkedTables contains the line:

collTables.Add Item:=.Name & .Connect, Key:=.Name

The part in bold would account for the strange concatenation. I just need to tweak it to create a valid connection string, which I should be able to figure out.

Thanks again guys.

[NeoPa]

In most cases that will work reliably Jay. The thing to do is to discover the exception (Tracing should help).

I suspect that code amended to use the .Attributes property, instead of the contents of the .Connect property, will handle the situation more reliably.