Code for Relationship Report with extended field information

Code to accompany the Relationship Report with Field Information article.  Last updated April 2010.

'Purpose:   Show additional information beside each field in the Print Relationships report.
'Author:    Allen Browne.. June 2006.
'Usage:     Set the On Click property of a command button to:
'               =RelReport()
'Method:    The Relationships report uses a list box for each table.
'           We open the report, switch to design view, and change the RowSource of each list box,
'           to give more detailed information on each field, by adding the codes below to each field.

' These codes are added to the field names in the Relationships report:

' Field Types:
' ===========
'  A    AutoNumber field (size Long Integer)+
'  Att  Attachment (always with the X prefix.)
'  Bin  Binary (not available in the interface.)
'  B    Byte (Number)
'  C    Currency
'  Dbl  Double (Number)
'  Dec  Decimal (Number)
'  Dt   Date/Time
'  Guid Replication ID (Globally Unique IDentifier)
'  Hyp  Hyperlink
'  Int  Integer (Number)
'  L    Long Integer (Number)
'  M    Memo field
'  Ole  OLE Object
'  Sng  Single (Number)
'  T    Text, with number of characters (size)
'  Tf   Text, fixed width, with number of characters (not available in the interface.)
'  Yn   Yes/No
'  ?    Unknown field type
'  X    prefix indicates a Complex data type, e.g. XL = Complex Long, XTf = Complext Text fixed-width.

' Indexes:
' =======
'  P    Primary Key
'  U    Unique Index ('No Duplicates')
'  I    Indexed ('Duplicates Ok')
' Note: Lower case p, u, or i indicates a secondary field in a multi-field index.

' Properties:
' ==========
'  D    Default Value set.
'  R    Required property is Yes
'  V    Validation Rule set.
'  Z    Allow Zero-Length is Yes (Text, Memo and Hyperlink only.)

Option Compare Database
Option Explicit

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.. 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 483        ' 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

Private Function TdfSetOk(db As DAO.Database, tdf As DAO.TableDef, ctl As Control, strErrMsg As String) As Boolean
On Error GoTo Err_Handler
    'Purpose:   Set the TableDef passed in, using the name in the Caption in the control's attached label.
    'Return:    True on success. (Fails if the caption is an alias.)
    'Arguments: db = database variable (must already be set).
    '           tdf = the TableDef variable to be set.
    '           ctl = the control that has the name of the table in its attached label.
    '           strMsg = string to append any error messages to.
    Dim strTable As String      'The name of the table.
    
    strTable = ctl.Controls(0).Caption  'Get the name of the table from the attached label's caption.
    Set tdf = db.TableDefs(strTable)    'Fails if the caption is an alias.
    TdfSetOk = True                     'Return true if it all worked.
    
Exit_Handler:
    Exit Function

Err_Handler:
    Select Case Err.Number
    Case 3265&  'Item not found in collection. (Table name is an alias.)
        strErrMsg = strErrMsg & "Skipped table " & strTable & vbCrLf
    Case Else
        strErrMsg = strErrMsg & "Error " & Err.Number & ": " & Err.Description & vbCrLf
    End Select
    Resume Exit_Handler
End Function

Private Function DescribeFields(tdf As DAO.TableDef) As String
    'Purpose:   Loop through the fields of the table, to create a string _
                    to use as the RowSource of the list box (Value List type).
    'Note:      We use literals instead of constants for the data types that do not exist before A2007.
    Dim fld As DAO.Field        'Each field of the table.
    Dim strType As String
    Dim strReturn As String     'String to build up and return.
    
    For Each fld In tdf.Fields
        'Skip replication info fields.
        If (fld.Attributes And dbSystemField) = 0& Then
            Select Case CLng(fld.Type)
                Case dbText
                    strType = IIf((fld.Attributes And dbFixedField) = 0&, "T", "Tf") & fld.Size & _
                        IIf(fld.AllowZeroLength, "Z", vbNullString)
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, strType)
                Case 109&   'dbComplexText
                    strType = IIf((fld.Attributes And dbFixedField) = 0&, "T", "Tf") & fld.Size & _
                        IIf(fld.AllowZeroLength, "Z", vbNullString)
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, strType, True)
                Case dbMemo
                    strType = IIf((fld.Attributes And dbHyperlinkField) = 0&, "M", "Hyp") & _
                        IIf(fld.AllowZeroLength, "Z", vbNullString)
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, strType)
                Case dbLong
                    strType = IIf((fld.Attributes And dbAutoIncrField) = 0&, "L", "A")
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, strType)
                Case 104&   'dbComplexLong
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "L", True)
                Case dbInteger
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Int")
                Case 103&   'dbComplexInteger
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Int", True)
                Case dbCurrency
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "C")
                Case dbDate
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Dt")
                Case dbDouble
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Dbl")
                Case 106&   'dbComplexDouble
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Dbl", True)
                Case dbSingle
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Sng")
                Case 105&   'dbComplexSingle
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Sng", True)
                Case dbByte
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "B")
                Case 102&   'dbComplexByte
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "B", True)
                Case dbDecimal
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Dec")
                Case 108&   'dbComplexDecimal
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Dec", True)
                Case dbBoolean
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Yn")
                Case dbLongBinary
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Ole")
                Case dbGUID
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Guid")
                Case 107&   'dbComplexGUID
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Guid", True)
                Case 101&   'dbAttachment
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Att", True)
                Case dbBinary
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "Bin")
                Case Else
                    strReturn = strReturn & DescribeFieldSub(tdf, fld, "?")
            End Select
        End If
    Next
    
    DescribeFields = strReturn & """     (" & DCount("*", tdf.Name) & ")"""
End Function

Private Function IsCalcTableField(fld As DAO.Field) As Boolean
    'Purpose: Returns True if fld is a calculated field (Access 2010 and later only.)
On Error GoTo ExitHandler
    Dim strExpr As String

    strExpr = fld.Properties("Expression")
    If strExpr <> vbNullString Then
        IsCalcTableField = True
    End If

ExitHandler:
End Function

Private Function DescribeFieldSub(tdf As TableDef, fld As Field, strTypeDescrip As String, Optional bIsComplex As Boolean) As String
    Dim strOut As String
    Const strcSep = ";"             'Separator between items in the list box.
    
    'strOut = IIf(bIsComplex, """X", """") & fld.Name & "    " & strTypeDescrip
    
    strOut = """" & fld.Name & "    "
    If bIsComplex Then
        strOut = strOut & "X"
    End If
    If IsCalcTableField(fld) Then
        strOut = strOut & "*"
    End If
    strOut = strOut & strTypeDescrip
    
    If fld.Required Then            'Required?
        strOut = strOut & "R"
    End If                          'Validation Rule?
    If fld.ValidationRule <> vbNullString Then
        strOut = strOut & "V"
    End If                          'Default Value?
    If fld.DefaultValue <> vbNullString Then
        strOut = strOut & "D"
    End If
    strOut = strOut & DescribeIndexField(tdf, fld.Name) & """" & strcSep
    If bIsComplex Then
        If fld.Type = 101 Then      'Attachment
            strOut = strOut & """    (" & fld.Name & ".FileData)""" & strcSep & _
                """    (" & fld.Name & ".FileName)""" & strcSep & _
                """    (" & fld.Name & ".FileType)""" & strcSep
        Else
            strOut = strOut & """    (" & fld.Name & ".Value)" & """" & strcSep
        End If
    End If
    DescribeFieldSub = strOut
End Function

Private Function DescribeIndexField(tdf As DAO.TableDef, strField As String) As String
    'Purpose:   Indicate if the field is part of a primary key or unique index.
    'Return:    String containing "P" if primary key, "U" if uniuqe index, "I" if non-unique index.
    '           Lower case letters if secondary field in index. Can have multiple indexes.
    'Arguments: tdf = the TableDef the field belongs to.
    '           strField = name of the field to search the Indexes for.
    Dim ind As DAO.Index        'Each index of this table.
    Dim fld As DAO.Field        'Each field of the index
    Dim iCount As Integer
    Dim strReturn As String     'Return string
    
    For Each ind In tdf.Indexes
        iCount = 0
        For Each fld In ind.Fields
            If fld.Name = strField Then
                If ind.Primary Then
                    strReturn = strReturn & IIf(iCount = 0, "P", "p")
                ElseIf ind.Unique Then
                    strReturn = strReturn & IIf(iCount = 0, "U", "u")
                Else
                    strReturn = strReturn & IIf(iCount = 0, "I", "i")
                End If
            End If
            iCount = iCount + 1
        Next
    Next
    
    DescribeIndexField = strReturn
End Function

Private Function SetMarginsAndOrientation(obj As Object) As Boolean
    'Purpose:   Set half-inch margins, and switch to landscape orientation.
    'Argument:  the report. (Object used, because Report won't compile in early versions.)
    'Return:    True if set.
    'Notes:     1. Applied in Access 2002 and later only.
    '           2. Setting orientation in design view and then opening in preview does not work reliably.
    Const lngcMargin = 720&     'Margin setting in twips (0.5")
    
    'Access 2000 and earlier do not have the Printer object.
    If Int(Val(SysCmd(acSysCmdAccessVer))) >= 10 Then
        With obj.Printer
            .TopMargin = lngcMargin
            .BottomMargin = lngcMargin
            .LeftMargin = lngcMargin
            .RightMargin = lngcMargin
            .Orientation = 2            'acPRORLandscape not available in A2000.
        End With
        
        'Return True if set.
        SetMarginsAndOrientation = True
    End If
End Function