Public P_BackendPath as string
Public Const C_BEName as string = "pbbe" ' Het eerste gedeelte van de backend naam bijv pbbe, de suffix is altijd .data
'
.
.
.
P_backendPath = "j:\data\pbbe.data" '
if not filexist (P_backendpath ) then selectbackend(P_backendPath)
If Not TestLinks Then
Call RemoveLinks
Call LinkDatabase
End If
Call TestorForceLinks
.
.
.
Public Function TestLinks() As Boolean
On Error GoTo Fout
Dim Maakl As Boolean
Dim Bel As String
Dim tdf As TableDef
Dim BackendPath As Variant
Maakl = False
TestLinks = False
BackendPath = DLookup("[Database]", "MSysObjects", "Not IsNull(Database)") 'haal backendlocatie uit huidige links
If IsNull(BackendPath) Then
Maakl = True
GoTo Verder2
End If
If BackendPath <> P_BackendPath Then
Maakl = True
GoTo Verder2
End If
For Each tdf In CurrentDb.TableDefs
If (tdf.Attributes And dbAttachedTable) = dbAttachedTable Then
Bel = Nz(DLookup("[Database]", "MSysObjects", "Foreignname=" & cq & tdf.Name & cq))
If Bel <> P_BackendPath Then
Maakl = True
GoTo Verder1
Else
' Application.SetHiddenAttribute acTable, tdf.Name, True
End If
'SysCmd acSysCmdSetStatus, "Test link table [" & tdf.name & "]..."
End If
Next tdf
Verder1:
Set tdf = Nothing
Verder2:
If Maakl Or P_ForceLink Then 'P_forcelink wordt aangezet bij updatebackend
P_SkipMaakLink = False
If RelinkTables(P_BackendPath) Then TestLinks = True
Else
P_SkipMaakLink = True
TestLinks = True
End If
Exit_fout:
Exit Function
Fout:
MsgBox Err.Description
SysCmd acSysCmdClearStatus
End Function
Public Sub TestorForceLinks()
' kijk of er een fout optreed bij het maken van de link naar kpbini zoja dan force links
On Error GoTo Forcelinks
Dim rstest As New ADODB.Recordset
Dim Getoond As Boolean
Set rstest = New ADODB.Recordset
rstest.Open "gebruikers", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
rstest.Close
Set rstest = Nothing
Exit Sub
Forcelinks:
Call RemoveLinks
Call LinkDatabase
End Sub
Public Sub RemoveLinks()
On Error Resume Next 'negeer fouten
'http://www.dbforums.com/microsoft-access/997455-error-trying-relink-vba.html
Dim tdf As TableDef
For Each tdf In CurrentDb.TableDefs
If Left(tdf.Name, 4) <> "MSys" And (tdf.Attributes And dbAttachedTable) = dbAttachedTable Then
CurrentDb.TableDefs.Delete tdf.Name
End If
Next tdf
Set tdf = Nothing
End Sub
Public Sub LinkDatabase()
'http://www.dbforums.com/microsoft-access/997455-error-trying-relink-vba.html
On Error GoTo Fout
Dim dbs As Database
Dim tdf As TableDef
Dim Getoond As Long
Dim rs As New ADODB.Recordset
Dim strDBPath As String
strDBPath = P_BackendPath
Set dbs = OpenDatabase(strDBPath, False, False, ";PWD=" & P_BackendPassWord)
rs.Open "kpbinife", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
Getoond = rs.Fields("opgestart")
If P_Runtime And Getoond > 0 Then
MsgBox ("Attentie!" & vbCrLf & vbCrLf & _
"De links naar de tabellen in de backend worden nu vernieuwd" & vbCrLf & vbCrLf & _
"Voor gebruikers van het runtime pakket kunnen nu beveiligingswaarschuwingen volgen!" & vbCrLf & vbCrLf & _
"Geef dan s.v.p. voor alle tabellen toestemming om te openen!" & vbCrLf & vbCrLf & _
"N.b. Dit wordt maar eenmaal gevraagd en komt alleen weer voor bij verandering van de backend!")
Getoond = Getoond + 1
rs.Fields("opgestart") = Getoond
rs.Update
rs.Close
Else
rs.Close
End If
For Each tdf In dbs.TableDefs
If Left(tdf.Name, 4) <> "MSys" Then
DoCmd.TransferDatabase acLink, "Microsoft Access", Trim(strDBPath), acTable, tdf.Name, tdf.Name
Application.SetHiddenAttribute acTable, tdf.Name, True
SysCmd acSysCmdSetStatus, "Processing table [" & tdf.Name & "]..."
End If
Next tdf
SysCmd acSysCmdClearStatus
Set dbs = Nothing
Set tdf = Nothing
Uit:
Exit Sub
Fout:
MsgBox "Linkdatabase : " & Err.Description
DoCmd.Quit
End Sub
Public Function SelectBackend(PathNaam1 As String) As Boolean
On Error GoTo Fout
Dim fd As FileDialog
Dim FileSpec As String
Dim VrtSelectedItem As Variant
SelectBackend = False
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Filters.Add "Files *(.data) ", "*.data"
.AllowMultiSelect = False
.Title = "Zoek en selecteer de backend " & C_BeName
.InitialFileName = CurDir
.InitialView = msoFileDialogViewDetails
If .Show = -1 Then
For Each VrtSelectedItem In .SelectedItems
If (InStr(VrtSelectedItem, Left(C_BeName, 4)) = 0) Or (InStr(Right(VrtSelectedItem, 4), "data") = 0) Then
MsgBox "S.v.p. selecteer " & C_BeName & " of een back-upbestand hiervan!"
SelectBackend = False
Else
PathNaam1 = VrtSelectedItem
SelectBackend = True
End If
Next VrtSelectedItem
'The user pressed Cancel.
End If
End With
Set fd = Nothing
Uit:
Exit Function
Fout:
MsgBox Err.Description
End Function
