Revincular tablas de diferentes tipos de origen

Hay ocasiones en las que una base de datos tiene vinculadas tablas de diferentes tipos de origen (ODBC, Excel, FoxPro etc). Con la siguiente función se pueden reestablecer los vínculos de una forma genérica con todos los orígenes de datos existentes.

La función puede ser llamada desde un formulario inicial cuando se inicia la aplicación. El siguiente ejemplo muestra como se llama a la función cuando se cierra el formulario inicial.

Private Sub Form_Close()
If fRefreshLinks = False Then
MsgBox “You have not refreshed the database links. This application ” & “will can not function and will be terminated.”
DoCmd.Quit
End If
End Sub

Para que este código funcione correctamente es necesario que la rutina GetOpenFileName, creada por Ken Getz, esté disponible en la aplicación. El siguiente código hay que colocarlo en un módulo.

Const IntAttachedTableType As Integer = 6
Const ALLFILES = “All Files”
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 fRefreshLinks() As Boolean
Dim dbs As Database
Dim rst As Recordset, rstTry As Recordset
Dim tdf As TableDef
Dim strOldConnect As String, strNewConnect As String
Dim strFullLocation As String, strDatabase As String, strMsg As String
Set dbs = CurrentDb()
Set rst = dbs.OpenRecordset(”SELECT MSysObjects.Connect, MsysObjects.Database, ” & “MSysObjects.Name from MSysObjects ” & “WHERE MSysObjects.Type = ” & IntAttachedTableType)
If rst.RecordCount <> 0 Then
rst.MoveFirst
Do
On Error Resume Next
Set rstTry = dbs.OpenRecordset(rst![Name].Value)
If Err = 0 Then
rstTry.Close
Set rstTry = Nothing
Else
On Error GoTo fRefreshLinks_Err
strFullLocation = rst.Name
strDatabase = FileName(strFullLocation)
Set tdf = dbs.TableDefs(rst![Name].Value)
strOldConnect = tdf.Connect
strNewConnect = findConnect(strDatabase, tdf.Name, strOldConnect)
‘If strNewConnect = “” Then
‘Err.Raise
‘Else
For Each tdf In dbs.TableDefs
If tdf.Connect = strOldConnect Then
tdf.Connect = strNewConnect
tdf.RefreshLink
End If
Next tdf
dbs.TableDefs.Refresh
‘End If
End If
Err = 0
rst.MoveNext
If rst.EOF Then
Exit Do
End If
Loop
End If
fRefreshLinks_End:
Set tdf = Nothing
Set rst = Nothing
Set rstTry = Nothing
fRefreshLinks = True
Exit Function
fRefreshLinks_Err:
fRefreshLinks = False
Select Case Err
Case 3024:
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”
End Select
Exit Function
End Function

Function findConnect(strDatabase As String, strFileName As String, strConnect As String) As Variant
Dim strSearchPath As String, strFileType As String, strFileSkelton As String
Dim aExtension(6, 1) As String, i As Integer, _
strFindFullPath As String, strFindPath As String, strParameters As String
strSearchPath = directoryFromConnect(strConnect)
strFileType = “All Files”
strFileSkelton = “*.*”
aExtension(0, 0) = “dBase”
aExtension(0, 1) = “.dbf”
aExtension(1, 0) = “Paradox”
aExtension(1, 1) = “.db”
aExtension(2, 0) = “FoxPro”
aExtension(2, 1) = “.dbf”
aExtension(3, 0) = “Excel”
aExtension(3, 1) = “.xls”
aExtension(4, 0) = “Text”
aExtension(4, 1) = “.txt”
aExtension(5, 0) = “Exchange”
aExtension(5, 1) = “.*”
aExtension(6, 0) = “Access”
aExtension(6, 1) = “.mdb”
For i = 0 To 6
If InStr(strConnect, aExtension(i, 0)) <> 0 Then
strFileName = strFileName & aExtension(i, 1)
strFileSkelton = “*” & aExtension(i, 1)
strFileType = aExtension(i, 0)
Exit For
End If
Next i
strFindFullPath = findFile(strDatabase, strSearchPath, strFileType, strFileSkelton)
If strFindFullPath <> “” Then
strFindPath = strPathfromFileName(strFindFullPath)
strParameters = parametersFromConnect(strConnect)
If InStr(strFindFullPath, “dbf”) <> 0 Then
findConnect = strParameters & strFindPath
Else
findConnect = strParameters & strFindFullPath
End If
End If
End Function
Function directoryFromConnect(strConnect As String) As String
directoryFromConnect = Mid(strConnect, InStr(strConnect, “DATABASE=”) + 9)
End Function
Function parametersFromConnect(strConnect As String) As String
parametersFromConnect = left(strConnect, InStr(strConnect, “DATABASE=”) + 8)
End Function
Function strPathfromFileName(strFileName As String) As String
Dim i As Integer
For i = Len(strFileName) To 1 Step -1
If Mid(strFileName, i, 1) = “\” Then
Exit For
End If
Next i
strPathfromFileName = left(strFileName, i – 1)
End Function

Function findFile(strDatabase, strSearchPath, strFileType, strFileSkelton) As String
Dim strSelectedDatabase As String, strFullLocation As String, intlen As Integer, i As Integer
Dim strIn As String
Do
strIn = “Where Is ” & strDatabase & “?”
findFile = Trim(fGetMDBName(strIn))
strSelectedDatabase = FileName(findFile)
If strSelectedDatabase = “” Then
Exit Do
ElseIf strDatabase <> strSelectedDatabase Then
MsgBox “You selected ” & strSelectedDatabase & “@This is not the correct database.@Please select ” & strDatabase & “.”, vbInformation + vbOKOnly
End If
Loop Until strSelectedDatabase = strDatabase
End Function

Public Function FileName(strFullLocation As String)
Dim intlen As Integer, i As Integer
‘Get the Database Name, for use on the ‘Find File’ Form Caption
intlen = Len(strFullLocation)
For i = intlen To 1 Step -1
If Mid$(strFullLocation, i, 1) = “\” Then
FileName = right$(strFullLocation, intlen – i)
Exit For
End If
Next i
End Function

Fuente: The access web