' Copyright 1993 Stephen Schmidt
' All Rights Reserved
'
' USERS OF THIS PROGRAM MUST ACCEPT THIS DISCLAIMER OF WARRANTY:  "THIS PROGRAM
' IS SUPPLIED AS IS.  THE AUTHOR DISCLAIMS ALL WARRANTIES, EXPRESSED OR
' IMPLIED, INCLUDING, WITHOUT LIMITATION, THE WARRANTIES OF MERCHANTABILITY AND
' OF FITNESS FOR ANY PURPOSE.  THE AUTHOR ASSUMES NO LIABILITY FOR DAMAGES,
' DIRECT OR CONSEQUENTIAL, WHICH MAY RESULT FROM THE USE OF THIS PROGRAM."
'
' Copyrighted freeware--you can do anything you want this module except remove
' the disclaimer or any of the copyright notices.  Thanks for your cooperation.
'
' Stephen Schmidt, CompuServe user 73200,3207.
'
'
' INSTRUCTIONS
'
'    To setup these functions:  Load them into a Module within your Access
'       database, Open the Module containing them, display the Immediate
'       Window, and type "Setup" (without the quotes, followed by {Enter}).
'       Once setup, you can select the "Access Relationships View" Query
'       from the Database Window.
'
'
Option Compare Database   'Use database order for string comparisons
Option Explicit

Const ModuleName = "Relationships Module"
Const VersionNum = "1.02"
Const ContactAuth = "If you are unable to resolve this problem, you can contact the author, Steve Schmidt.  (Send an Internet mail message to address 73200.3207@compuserve.com or a CompuServe Mail message to user 73200,3207.  Include the version #, error #, and line # of this error in your message.  A reply is not guaranteed.)"

' Used to receive a portion of the MSysIndexes Table Rgkeyd Column value.
Type MSysIndexesRgkeydString
    S As String * 8
End Type

' Used to interpret the part of the MSysIndexes Table Rgkeyd Column that
' refers to the key Column.
Type MSysIndexesRgkeydLong
    L As Long
End Type

' Function Parameters
' MsgBox parameters
Const MB_OK = 0                 ' OK button only
Const MB_OKCANCEL = 1           ' OK and Cancel buttons
Const MB_ABORTRETRYIGNORE = 2   ' Abort, Retry, and Ignore buttons
Const MB_YESNOCANCEL = 3        ' Yes, No, and Cancel buttons
Const MB_YESNO = 4              ' Yes and No buttons
Const MB_RETRYCANCEL = 5        ' Retry and Cancel buttons

Const MB_ICONSTOP = 16          ' Critical message
Const MB_ICONQUESTION = 32      ' Warning query
Const MB_ICONEXCLAMATION = 48   ' Warning message
Const MB_ICONINFORMATION = 64   ' Information message

Const MB_APPLMODAL = 0          ' Application Modal Message Box
Const MB_DEFBUTTON1 = 0         ' First button is default
Const MB_DEFBUTTON2 = 256       ' Second button is default
Const MB_DEFBUTTON3 = 512       ' Third button is default
Const MB_SYSTEMMODAL = 4096      'System Modal

' MsgBox return values
Const IDOK = 1                  ' OK button pressed
Const IDCANCEL = 2              ' Cancel button pressed
Const IDABORT = 3               ' Abort button pressed
Const IDRETRY = 4               ' Retry button pressed
Const IDIGNORE = 5              ' Ignore button pressed
Const IDYES = 6                 ' Yes button pressed
Const IDNO = 7                  ' No button pressed

Function MSysIndexesRgkeydToColumnNames (ObjectId As Variant, Rgkeyd As Variant) As Variant
        ' Copyright 1993 Stephen Schmidt
        ' All Rights Reserved
    
        ' Accepts an ObjectId and Rgkeyd value, and it returns the Column names represented
        ' by the Rgkeyd value.
    
        Static ErrorGiven As Integer
        On Error GoTo MSIRTCN_Error
    
2030    If VarType(ObjectId) <> V_LONG Or VarType(Rgkeyd) <> V_STRING Then Exit Function
2040    If Len(Rgkeyd) Mod 8 <> 0 Then Exit Function
    
2050    Dim AllColumnNames As Variant
2060    AllColumnNames = Null
    
        ' Review each segment of the Rgkeyd string;
        ' each segment represents one key column.
2070    Dim CurrentColumnNumber As Integer
2080    For CurrentColumnNumber = 0 To Len(Rgkeyd) \ 8 - 1
            ' Get the correct portion of the Rgkeyd string for interpretation.
2090        Dim S As MSysIndexesRgkeydString
2100        S.S = Mid(Rgkeyd, CurrentColumnNumber * 8 + 1, 8)
    
            ' Copy current portion of Rgkeyd string into record with a long element.
2110        Dim L As MSysIndexesRgkeydLong
2120        LSet L = S
    
            ' Lookup the Column name represented by the ObjectId and HColumn value;
            ' the HColumn value is what's embedded within the Rgkeyd value.
2130        Dim CurrentColumnName As Variant
2140        CurrentColumnName = DLookup("Name", "Access Relationships Lookup", "ObjectId = " & ObjectId & " and HColumn = " & L.L)
            
            ' Accumulate all of the Column names that are part of the current Relationship.
2150        If IsNull(AllColumnNames) Then
2160            AllColumnNames = CurrentColumnName
2170        Else
2180            AllColumnNames = AllColumnNames & ", " & CurrentColumnName
2190        End If
2200    Next CurrentColumnNumber
    
        ' Return the Column list.
2210    MSysIndexesRgkeydToColumnNames = AllColumnNames
    
MSIRTCN_End:
        Exit Function
    
MSIRTCN_Error:
        If Not ErrorGiven Then MsgBox "Unexpected error #" & Err & " at line #" & Erl & ": " & Error$ & Chr$(13) & Chr$(10) & Chr$(13) & Chr$(10) & "This error message indicates that some problem has developed since the Relationships module was installed.  (This function will now silently ignore other errors that occur during this Access session.)  Either you or your system administrator should attempt to re-install this module.  (Select the Database window, view the Modules, open the Relationships module, display the Immediate Window, type ""Relationships"" (without the quotes), and press {Enter}.)" & Chr$(13) & Chr$(10) & Chr$(13) & Chr$(10) & ContactAuth, MB_ICONSTOP, ModuleName & " version " & VersionNum
        ErrorGiven = True
        Resume MSIRTCN_End
End Function

Private Sub Setup ()
        ' Copyright 1993 Stephen Schmidt
        ' All Rights Reserved

        ' SETUP THE ACCESS RELATIONSHIPS QUERY:
        '   Create the Query required to view the Access Relationships,
        '   then Open the Query as a test.

        ' The required Query Definitions will be created with the following names:
        Const MAIN_NAME = "Access Relationships View"
        Const LOOKUP_NAME = "Access Relationships Lookup"

        ' Setup error checking to detect most problems.
        On Error GoTo Rel_Error
1100    DoCmd Hourglass True

        ' Open the current database.
1110    Dim CurDb As Database
1120    Set CurDb = CurrentDB()

1130    Dim ChkCols As Dynaset
1140    Const LINE_CREATEDYNASET_COLS = 1150
1150    Set ChkCols = CurDb.CreateDynaset("MSysColumns")

1160    Dim ChkIdxs As Dynaset
1170    Const LINE_CREATEDYNASET_IDXS = 1180
1180    Set ChkIdxs = CurDb.CreateDynaset("MSysIndexes")

1190    Dim ChkObjs As Dynaset
1200    Const LINE_CREATEDYNASET_OBJS = 1210
1210    Set ChkObjs = CurDb.CreateDynaset("MSysObjects")

1220    Dim Stmt As String

        ' Assemble the SELECT statement for the Query Def. used to interpret column names.
3010    Stmt = ""
3020    Stmt = Stmt + "   SELECT"
3030    Stmt = Stmt + "      ObjectId,"
3040    Stmt = Stmt + "      HColumn,"
3050    Stmt = Stmt + "      Name"
3060    Stmt = Stmt + "   FROM"
3070    Stmt = Stmt + "      MSysColumns"
3080    Stmt = Stmt + "   WITH OWNERACCESS OPTION;"

        ' Delete the Query if it already exists.
1230    Const LINE_DELETEQUERYDEF_LOOKUP = 1240
1240    CurDb.DeleteQueryDef LOOKUP_NAME

        ' Create the Query Definition.
1250    Dim LQuery As QueryDef
1260    Set LQuery = CurDb.CreateQueryDef(LOOKUP_NAME, Stmt)

        ' Assemble the SELECT statement for the main Query Def.
4010    Stmt = ""
4020    Stmt = Stmt + "   SELECT"
4030    Stmt = Stmt + "      fko.Name AS FKTable,"
4040    Stmt = Stmt + "      pko.Name AS PKTable,"
4050    Stmt = Stmt + "      MSysIndexesRgkeydToColumnNames([pk].[ObjectIdReference],[pk].[RgkeydReference]) AS FKColumns,"
4060    Stmt = Stmt + "      MSysIndexesRgkeydToColumnNames([pk].[ObjectId],[pk].[Rgkeyd]) AS PKColumns,"
4070    Stmt = Stmt + "      IIf(fk.FUnique, ""No"", ""Yes"") AS IsOneToMany,"
4080    Stmt = Stmt + "      IIf(fk.FDontEnforce, ""No"", ""Yes"") AS EnforceIntegrity"
4090    Stmt = Stmt + "   FROM"
4100    Stmt = Stmt + "      MSysIndexes AS pk,"
4110    Stmt = Stmt + "      MSysIndexes AS fk,"
4120    Stmt = Stmt + "      MSysObjects AS pko,"
4130    Stmt = Stmt + "      MSysObjects AS fko,"
4140    Stmt = Stmt + "      fko INNER JOIN fk ON fko.Id = fk.ObjectId,"
4150    Stmt = Stmt + "      pk INNER JOIN pko ON pk.ObjectId = pko.Id,"
4160    Stmt = Stmt + "      pk INNER JOIN fk ON pk.ObjectIdReference = fk.ObjectId,"
4170    Stmt = Stmt + "      pk INNER JOIN fk ON pk.ObjectId = fk.ObjectIdReference"
4180    Stmt = Stmt + "   WHERE"
4190    Stmt = Stmt + "      pk.Operation = 2"
4200    Stmt = Stmt + "      And"
4210    Stmt = Stmt + "      fk.Operation = 1"
4220    Stmt = Stmt + "   ORDER BY"
4230    Stmt = Stmt + "      fko.Name,"
4240    Stmt = Stmt + "      pko.Name"
4250    Stmt = Stmt + "   WITH OWNERACCESS OPTION;"

        ' Delete the Query if it already exists.
1270    Const LINE_DELETEQUERYDEF_MAIN = 1280
1280    CurDb.DeleteQueryDef MAIN_NAME

        ' Create the Query Definition.
1295    Dim RQuery As QueryDef
1300    Set RQuery = CurDb.CreateQueryDef(MAIN_NAME, Stmt)

        ' Optionally open the newly-created main Query.
1310    DoCmd Hourglass False
1320    Dim TwoCrNls As String
1330    TwoCrNls = Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10)
1340    If IDYES = MsgBox("The Relationships module has been successfully installed." + TwoCrNls + "A sample query of Access table relationships has been created with the name """ + MAIN_NAME + ".""  In the future, you can open this query directly, or use its MSysIndexesRgkeydToColumnNames function within other queries.  (The MSysIndexesRgkeydToColumnNames function requires a query which has been created with the name """ + LOOKUP_NAME + "."")  Note to users of secured databases:  Users of the this module must have ""Read Definitions"" and ""Read Data"" Permission to the """ + MAIN_NAME + """ and """ + LOOKUP_NAME + """ Queries." + TwoCrNls + "Open the sample Query as a test?", MB_ICONINFORMATION + MB_YESNO + MB_DEFBUTTON1, ModuleName + " version " + VersionNum) Then
1350        DoCmd OpenQuery MAIN_NAME
1360    End If
1370    DoCmd Hourglass True

Rel_End:
        ' Ignore any cleanup-related errors.
        On Error Resume Next

        ' Close the Dynasets used to check permissions of the underlying base tables.
        ' Within a secured database, the creator of the Access Relationships Query must have permission on these tables.
        ChkCols.Close
        ChkIdxs.Close
        ChkObjs.Close
        
        ' Close the QueryDef and the Database.
        LQuery.Close
        RQuery.Close
        CurDb.Close
                
        DoCmd Hourglass False
        Exit Sub

Rel_Error:
        Const ERROR_COULDNT_FIND_OBJECT = 3011
        Const ERROR_COULDNT_READ_NO_READ_PERMISSION = 3112

        Dim AddHelp As String
        AddHelp = ""

        ' Intercept certain error conditions, and enhance certain error messages.
        Select Case Err
            Case ERROR_COULDNT_FIND_OBJECT
                Select Case Erl
                    Case LINE_DELETEQUERYDEF_MAIN, LINE_DELETEQUERYDEF_LOOKUP
                        ' Ignore the case where the Query Defs. does not already exist.
                        Resume Next
                End Select

            Case ERROR_COULDNT_READ_NO_READ_PERMISSION
                Select Case Erl
                    Case LINE_CREATEDYNASET_COLS, LINE_CREATEDYNASET_IDXS, LINE_CREATEDYNASET_OBJS
                        AddHelp = Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10) + "As the user installing this module, you must have permission to read the data within certain system tables."

                        If User() = "Admin" Then
                            AddHelp = AddHelp + "  (I will assume that you are responsible for system administration tasks, since you are logged-in as the ""Admin"" user of this database.)  1.  Use the View menu, Options command to make the system tables visible within the Database window.  (Change the General options, Show System Objects setting to Yes.)  2.  Use the Database window, Security menu, Permissions command to grant read permission on these tables to yourself."
                        Else
                            AddHelp = AddHelp + "  (I assume that your are not responsible for system administration tasks, since you are not logged-in as the ""Admin"" user of this database.)  1.  Contact your System Administrator and have him or her grant the appropriate permissions."
                        End If
                        
                        AddHelp = AddHelp + "  (Grant Read Data permission on the tables MSysColumns, MSysIndexes, and MSysObjects to user " & User() & ".)"
                End Select
        End Select

        DoCmd Hourglass False
        MsgBox "Unexpected error #" & Err & " at line #" & Erl & ": " & Error$ & AddHelp & Chr$(13) & Chr$(10) & Chr$(13) & Chr$(10) & ContactAuth, MB_ICONSTOP, ModuleName & " version " & VersionNum
        Resume Rel_End
End Sub

