VBA to Link to Network path instead of Network Drive - but Reverts back to Network Drive? 3

[kjv1611]

I've got a database project built, and mostly works fine, regardless of network path or mapped drive... however... we've recently been running into issues where this is becoming an issue.

Because of that, I built the following code to loop through all linked tables, and modify to use the actual network path instead of Mapped drive path. And it looked like it worked. But as soon as I copy the database, and send to those folks again, it doesn't work.

So, can anyone tell me what I'm doing wrong?

Sub GetTableDescription()
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    
    Set db = CurrentDb
    For Each tdf In db.TableDefs
        If tdf.Connect = vbNullString Then
        Else
            Debug.Print "---------------------------------------------------------"
            Debug.Print tdf.Connect
            tdf.Connect = Replace(tdf.Connect, "G:", "\\networkname\...networkpath")
            Debug.Print tdf.Connect
            Debug.Print vbCrLf
        End If
        
    Next tdf
    
    If tdf Is Nothing Then Else Set tdf = Nothing
    
End Sub

Thanks for any suggestions, references, etc.


"But thanks be to God, which giveth us the victory through our Lord Jesus Christ." 1 Corinthians 15:57

 

[dhookom]

I would add a line like:

    '....
    tdf.Connect = Replace(tdf.Connect, "G:", "\\networkname\...networkpath")
    [b]tdf.RefreshLink[/b]
'....

Duane
Hook'D on Access
MS Access MVP

 

[lameid]

Anybody remember else remember when the help files had remarks and examples to tell you when a second statement was required to make things works? I mean all MS had to do is NOT update the topic since Access 97.

See the added line below...

Sub GetTableDescription()
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    
    Set db = CurrentDb
    For Each tdf In db.TableDefs
        If tdf.Connect = vbNullString Then
        Else
            Debug.Print "---------------------------------------------------------"
            Debug.Print tdf.Connect
            tdf.Connect = Replace(tdf.Connect, "G:", "\\networkname\...networkpath")
            [b][red]tdf.RefreshLink[/red][/b]
            Debug.Print tdf.Connect
            Debug.Print vbCrLf
        End If
        
    Next tdf
    
    If tdf Is Nothing Then Else Set tdf = Nothing

End Sub

 

[bubba100]

This works for my needs. I would give proper credit to the person who wrote this if I knew who did. Wasn't me. Put this in a module and call it (fRefreshLinks).

Option Compare Database
Option Explicit

'***************** Code Start ***************
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
'***************** Code End ***************

 

[kjv1611]

Thanks for all the suggestions. I've not yet looked back at it, but hope to ... by tomorrow? Well, the idea seems to make sense to me - that I could just add the one line. I'll definitely play around with the function from bubba100 as well, seems like it's worth looking at, at least. I'd come across a couple of examples of something similar online, do not recall whether I found the same thing or not - but I know I did not yet try any such.

Thanks again.

"But thanks be to God, which giveth us the victory through our Lord Jesus Christ." 1 Corinthians 15:57