acCmdDesignView, acCmdPrintRelationships, acCmdRelationships

Code Examples

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 ********************

© 1998 - 2011 Terry Wickenden TKW Design Site developed maintained and hosted by TKW Design. This site is best viewed at 1024 x 768. Optimised for Firefox.