Print the Relationships Diagram
acCmdDesignView, acCmdPrintRelationships, acCmdRelationships
This code was posted by Allen Browne on one of the newgroups. If you use it please retain the original Author information.
'***************** Code Start *******************
Public Function RelReport(Optional bSetMarginsAndOrientation As Boolean = True) As Long
'On Error GoTo Err_Handler
'Purpose: Main routine. Opens the relationships report with extended field information.
'Author: Allen Browne. allen@allenbrowne.com. January 2006.
'Argument: bSetMarginsAndOrientation = False to NOT set margins and landscape.
'Return: Number of tables adjusted on the Relationships report.
'Notes: 1. Only tables shown in the Relationships diagram are processed.
' 2. The table's record count is shown in brackets after the last field.
' 3. Aliased tables (typically duplicate copies) are not processed.
' 4. System fields (used for replication) are suppressed.
' 5. Setting margins and orientation operates only in Access 2002 and later.
Dim db As DAO.Database 'This database.
Dim tdf As DAO.TableDef 'Each table referenced in the Relationships window.
Dim ctl As Control 'Each control on the report.
Dim lngKt As Long 'Count of tables processed.
Dim strReportName As String 'Name of the relationships report
Dim strMsg As String 'MsgBox message.
'Initialize: Open the Relationships report in design view.
Set db = CurrentDb()
strReportName = OpenRelReport(strMsg)
If strReportName <> vbNullString Then
'Loop through the controls on the report.
For Each ctl In Reports(strReportName).Controls
If ctl.ControlType = acListBox Then
'Set the TableDef based on the Caption of the list box's attached label.
If TdfSetOk(db, tdf, ctl, strMsg) Then
'Change the RowSource to the extended information
ctl.RowSource = DescribeFields(tdf)
lngKt = lngKt + 1& 'Count the tables processed successfully.
End If
End If
Next
'Results
If lngKt = 0& Then
'Notify the user if the report did not contain the expected controls.
strMsg = strMsg & "Diagram of tables not found on report " & strReportName & vbCrLf
Else
'Preview the report.
Reports(strReportName).Section(acFooter).Height = 0&
DoCmd.OpenReport strReportName, acViewPreview
'Reduce margins and switch to landscape (Access 2002 and later only.)
If bSetMarginsAndOrientation Then
Call SetMarginsAndOrientation(Reports(strReportName))
End If
End If
End If
Exit_Handler:
'Show any message.
If strMsg <> vbNullString Then
MsgBox strMsg, vbInformation, "Relationships Report (adjusted)"
End If
'Clean up
Set ctl = Nothing
Set db = Nothing
'Return the number of tables processed.
RelReport = lngKt
Exit Function
Err_Handler:
strMsg = strMsg & "RelReport: Error " & Err.Number & ": " & Err.Description & vbCrLf
Resume Exit_Handler
End Function
Private Function OpenRelReport(strErrMsg As String) As String
On Error GoTo Err_Handler
'Purpose: Open the Relationships report.
'Return: Name of the report. Zero-length string on failure.
'Argument: String to append any error message to.
Dim iAccessVersion As Integer 'Access version.
iAccessVersion = Int(Val(SysCmd(acSysCmdAccessVer)))
Select Case iAccessVersion
Case Is < 9
strErrMsg = strErrMsg & "Requires Access 2000 or later." & vbCrLf
Case 9
RunCommand acCmdRelationships
SendKeys "%FR", True 'File | Relationships. RunCommand acCmdPrintRelationships is not in A2000.
RunCommand acCmdDesignView
Case Is > 9
RunCommand acCmdRelationships
RunCommand acCmdPrintRelationships
RunCommand acCmdDesignView
End Select
'Return the name of the last report opened
OpenRelReport = Reports(Reports.Count - 1&).Name
Exit_Handler:
Exit Function
Err_Handler:
Select Case Err.Number
Case 2046& 'Relationships window is already open.
'A2000 cannot recover, because SendKeys requires focus on the window.
If iAccessVersion > 9 Then
Resume Next
Else
strErrMsg = strErrMsg & "Close the relationships window, and try again." & vbCrLf
Resume Exit_Handler
End If
Case 2451&, 2191& 'Report not open, or not open in design view.
strErrMsg = strErrMsg & "The Relationships report must be open in design view." & vbCrLf
Resume Exit_Handler
Case Else
strErrMsg = strErrMsg & "Error " & Err.Number & ": " & Err.Description & vbCrLf
Resume Exit_Handler
End Select
End Function
'****************** Code End ********************
