Follow along with the video below to see how to install our site as a web app on your home screen.
Note: This feature may not be available in some browsers.
Public Function Reattach(ByVal pstrFullFile As String) As Boolean
On Error GoTo HandleErrors
Dim tdfSource As DAO.TableDef
Dim tdfMe As DAO.TableDef
Dim rst As DAO.Recordset
Dim dbMe As DAO.Database
Dim dbSource As DAO.Database
Dim i As Integer
Dim bleLinkLocal As Boolean
Dim intCount As Integer
Dim varSysCmd As Variant
DoCmd.Hourglass True
Reattach = True
Set dbSource = OpenDatabase(pstrFullFile)
Set dbMe = CurrentDb
'this part deletes attachments
With dbMe
For i = .TableDefs.Count - 1 To 0 Step -1
Set tdfMe = .TableDefs(i)
With tdfMe
If (.Attributes And dbAttachedTable) = dbAttachedTable Then
dbMe.TableDefs.Delete (.Name)
End If
End With
Next i
End With
dbMe.TableDefs.Refresh
i = 0
'this part attaches to pstrFullFile tables
With dbSource
varSysCmd = SysCmd(acSysCmdInitMeter, "Linking tables from " & pstrFullFile & "...", .TableDefs.Count)
For Each tdfSource In .TableDefs
bleLinkLocal = False
If Left(tdfSource.Name, 4) <> "MSys" Then
For Each tdfMe In dbMe.TableDefs
If tdfMe.SourceTableName = tdfSource.Name Then
bleLinkLocal = True
Exit For
End If
Next tdfMe
Set tdfMe = Nothing
If Not bleLinkLocal Then
Set tdfMe = dbMe.CreateTableDef(tdfSource.Name)
With tdfMe
.Connect = ";Database=" & dbSource.Name
.SourceTableName = tdfSource.Name
End With
dbMe.TableDefs.Append tdfMe
'Hide table: tdf.Attributes = dbHiddenObject
tdfMe.RefreshLink
End If
i = i + 1
varSysCmd = SysCmd(acSysCmdUpdateMeter, i)
End If
Next tdfSource
'this part I use to record attached file name in a table utblSysAdmin. Delete it if you don't want it.
Set rst = .TableDefs("utblSysAdmin").OpenRecordset(dbOpenTable)
With rst
.Edit
!AttachFile = pstrFullFile
.Update
.Close
End With
.Close
End With
ExitHere:
'If Not (dbSource Is Nothing) Then dbSource.Close
Set dbMe = Nothing
Set tdfMe = Nothing
Set tdfSource = Nothing
varSysCmd = SysCmd(acSysCmdRemoveMeter)
Application.Echo True
DoCmd.Hourglass False
Exit Function
HandleErrors:
Reattach = False
If Err = 3011 Then
If MsgBox("Table " & tdfMe.Name & " not found. Would you like to " _
& "permanently remove the link to this table?", vbYesNo + vbQuestion) = vbYes Then
dbMe.TableDefs.Delete (tdfMe.Name)
End If
Resume Next
Else
'your generic error handler here
Reattach = False
Resume ExitHere
End If
End Function