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. allen@allenbrowne.com. 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. 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 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
| Home | Index of tips | Top |