Option Compare Database
Option Explicit
Public Sub ReLinkTbl()
On Error GoTo Err_Dot:
DoCmd.Echo False 'close form repaint action
DoCmd.Hourglass True 'change the mouse to hourglass icon
DoCmd.SetWarnings False 'close system hint
Dim mydb As DAO.Database
Dim MyTable As DAO.TableDef
Dim strTblName As String
Dim MySet As DAO.Recordset
Dim i As Integer, j As Integer
Dim connectstr As String
Dim intFlag As Boolean
Dim strAttributes As String
RefreshTblSysTables 'when add linked table, then need run this line.
'DoEvents---Yields execution so that the operating system can process other events.
Set mydb = DBEngine.Workspaces(0).Databases(0)
Set MySet = CurrentDb.OpenRecordset("TblSysTables", dbOpenTable, dbSeeChanges, dbOptimistic)
If MySet.RecordCount > 0 Then
MySet.MoveFirst
For j = 1 To MySet.RecordCount
intFlag = True
strTblName = MySet.Fields("TblName")
Set MyTable = mydb.TableDefs(strTblName)
MyTable.Connect = connectstr
MyTable.RefreshLink
If intFlag Then
MySet.Edit
MySet.Fields("ConnectFlag") = 1
MySet.Fields("Flag") = "OK"
'MySet.Fields("TblPropertiy") = CurrentDb.TableDefs(strTblName).Connect
MySet.Update
End If
MySet.MoveNext
Err.Clear
Next
Else
Exit Sub
End If
' use connect string without password to refresh table's connect string to hide password for avoiding disclose password in Msysobject table.
connectstr = "ODBC;DSN=XXX;"
'connectstr = connectstr & "SERVER=XXX;"
connectstr = connectstr & "APP=Microsoft Office 2003;" '"WSID= " & XXX & " ;"
connectstr = connectstr & "DATABASE=XXX;"
connectstr = connectstr & "QuotedId=No;AnsiNPW=Yes;"
connectstr = connectstr & "LANGUAGE=us_english;AutoTranslate=No" & Chr(0)
If MySet.RecordCount > 0 Then
MySet.MoveFirst
For j = 1 To MySet.RecordCount
intFlag = True
strTblName = MySet.Fields("TblName")
Set MyTable = mydb.TableDefs(strTblName)
MyTable.Connect = connectstr
MyTable.RefreshLink
If intFlag Then
MySet.Edit
MySet.Fields("ConnectFlag") = 1
MySet.Fields("Flag") = "OK"
MySet.Update
End If
MySet.MoveNext
Err.Clear
Next
End If
GoTo Exit_Port
Err_Dot:
If Err <> 0 Then
MsgBox "Refresh Link Table--->Error source: " & "-->" & Err.Number & "---" & Err.Description, vbOKOnly, "Tsilon sys!"
GoTo Exit_Port
End If
Exit_Port:
If Not (MySet Is Nothing) Then
MySet.Close
End If
Set MySet = Nothing
Application.Echo True
DoCmd.Hourglass False
DoCmd.SetWarnings True
Exit Sub
End Sub
Public Sub RefreshTblSysTables()
On Error Resume Next
Dim MyTbl As DAO.TableDefs, i As Integer
Dim rsSet As DAO.Recordset
DoCmd.RunSQL "Delete * From TblSysTables"
Set MyTbl = CurrentDb.TableDefs
Set rsSet = CurrentDb.OpenRecordset("TblSysTables")
For i = 0 To MyTbl.Count - 1
If MyTbl(i).Attributes = DB_ATTACHEDODBC Or MyTbl(i).Attributes = DB_ATTACHEDODBC + DB_ATTACHSAVEPWD Then
rsSet.AddNew
rsSet.Fields("ConnectFlag") = 0
rsSet.Fields("TblName") = MyTbl(i).Name
rsSet.Update
End If
Next
rsSet.Close
Set rsSet = Nothing
End Sub
