JSSAggie said:
I want to be able to remove referential integrity through SQL or
through an API before I excecute some updates to the DB. Then I
would like to turn it back on. I have referential integrity set on
alot of tables for one of my applications at work. I have written a
DB maintanence utility that I send DB updates to. I might just want
to be able to remove referential integrity on the table that I need
to work with. If I could get to these machines then I would just do
it through the GUI.
Maybe these code routines will help you, or serve as a starting point.
I've used them in one of my applications, but that does *not* mean they
are proven error-free, merely that they were good enough to serve my
purposes at the time.
'----- start of code for module basRelationships -----
Option Compare Database
Option Explicit
Function fncBackupRelationships() As Boolean
' Backup the current relationships into a user table (prior to
deleting them).
' Return True if the relationships were successfully backed up,
False (with
' error message and log entry) if not.
On Error GoTo Err_fncBackupRelationships
Dim db As DAO.Database
Dim rel As DAO.Relation
Dim fld As DAO.Field
Dim strSQL As String
Dim lngBackupCount As Long
Set db = CurrentDb
' Delete the backup table we'll be (re-)creating.
On Error Resume Next 'disable error-handling
db.TableDefs.Delete "USysBackupRelationships"
db.TableDefs.Delete "USysBackupRelationshipFields"
On Error GoTo Err_fncBackupRelationships 'restore error-handling
strSQL = "CREATE TABLE USysBackupRelationships (" & _
"RelationName TEXT(255), TableName TEXT(255), " & _
"ForeignTable TEXT(255), " & _
"Attributes INTEGER);"
db.Execute strSQL, dbFailOnError
strSQL = "CREATE TABLE USysBackupRelationshipFields (" & _
"RelationName TEXT(255), FieldName TEXT(255),
ForeignFieldName TEXT(255));"
db.Execute strSQL, dbFailOnError
For Each rel In db.Relations
With rel
If Left(.Name & "XXXX", 4) = "MSys" Then
'Debug.Print "--> Skipping " & .Name
Else
'Debug.Print "*** Backing up " & .Name
strSQL = _
"INSERT INTO USysBackupRelationships (" & _
"RelationName, TableName, ForeignTable, " & _
"Attributes) " & _
"VALUES (" & Chr(34) & .Name & Chr(34) & _
", " & Chr(34) & .Table & Chr(34) & _
", " & Chr(34) & .ForeignTable & Chr(34) & _
", " & .Attributes & ");"
db.Execute strSQL, dbFailOnError
For Each fld In .Fields
'Debug.Print fld.Name, fld.ForeignName
strSQL = _
"INSERT INTO USysBackupRelationshipFields (" & _
"RelationName, FieldName, ForeignFieldName)
" & _
"VALUES (" & Chr(34) & .Name & Chr(34) & _
", " & Chr(34) & fld.Name & Chr(34) & _
", " & Chr(34) & fld.ForeignName & Chr(34) &
");"
db.Execute strSQL, dbFailOnError
Next fld
' This relationship was successfully backed up.
lngBackupCount = lngBackupCount + 1
End If
End With
Next rel
fncBackupRelationships = True
RefreshDatabaseWindow
Exit_fncBackupRelationships:
On Error Resume Next
If Not db Is Nothing Then
db.Close
Set db = Nothing
End If
Exit Function
Err_fncBackupRelationships:
fncBackupRelationships = False
subDisplayAndLogError _
"fncBackupRelationships", _
Err.Number, _
"Failed to back up relationships - " & Err.Description
Resume Exit_fncBackupRelationships
End Function
Function fncDeleteRelationships() As Boolean
' Delete the relationships that have been backed up. Note that
' relationships that have not been backed up will not be deleted.
On Error GoTo Err_fncDeleteRelationships
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rel As DAO.Relation
Dim strSQL As String
If Not fncUserIsInGroup("Admins") Then
DoCmd.Beep
MsgBox "You are not authorized to perform this function.", _
vbInformation, "Permission Denied"
Exit Function
End If
If MsgBox("Are you sure you want to delete relationships? " & _
"This is a potentially lethal operation!", _
vbExclamation + vbYesNo + vbDefaultButton2, _
"Are You Sure?") _
<> vbYes _
Then
Exit Function
End If
Set db = CurrentDb
strSQL = "SELECT RelationName FROM USysBackupRelationships;"
Set rs = db.OpenRecordset(strSQL)
With rs
Do Until .EOF
db.Relations.Delete !RelationName
.MoveNext
Loop
End With
fncDeleteRelationships = True
Exit_fncDeleteRelationships:
On Error Resume Next
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
If Not db Is Nothing Then
db.Close
Set db = Nothing
End If
Exit Function
Err_fncDeleteRelationships:
fncDeleteRelationships = False
subDisplayAndLogError _
"fncDeleteRelationships", _
Err.Number, _
"Failed to delete relationships - " & Err.Description
Resume Exit_fncDeleteRelationships
End Function
Function fncRestoreRelationships() As Boolean
' Restore the relationships that have been backed up.
On Error GoTo Err_fncRestoreRelationships
Dim db As DAO.Database
Dim rsRel As DAO.Recordset
Dim rsFld As DAO.Recordset
Dim rel As DAO.Relation
Dim fld As DAO.Field
Dim strSQL As String
Set db = CurrentDb
strSQL = "SELECT * FROM USysBackupRelationships;"
Set rsRel = db.OpenRecordset(strSQL)
With rsRel
Do Until .EOF
Set rel = db.CreateRelation( _
!RelationName, !TableName, !ForeignTable, !Attributes)
strSQL = _
"SELECT * FROM USysBackupRelationshipFields " & _
"WHERE RelationName = " & Chr(34) & !RelationName &
Chr(34) & ";"
Set rsFld = db.OpenRecordset(strSQL)
With rsFld
Do Until .EOF
Set fld = rel.CreateField(!FieldName)
fld.ForeignName = !ForeignFieldName
rel.Fields.Append fld
.MoveNext
Loop
.Close
End With
db.Relations.Append rel
.MoveNext
Loop
End With
fncRestoreRelationships = True
Exit_fncRestoreRelationships:
On Error Resume Next
If Not rsRel Is Nothing Then
rsRel.Close
Set rsRel = Nothing
End If
If Not db Is Nothing Then
db.Close
Set db = Nothing
End If
Exit Function
Err_fncRestoreRelationships:
fncRestoreRelationships = False
subDisplayAndLogError _
"fncRestoreRelationships", _
Err.Number, _
"Failed to restore relationships - " & Err.Description
Resume Exit_fncRestoreRelationships
End Function
'----- end of code for module basRelationships -----
