Mostrar relaciones en una base de datos de Access, SQL para una consulta + función VBA

VBA

Módulo estándar

Coloque esta función en un módulo estándar para poder usarla en una declaración SQL, como en una consulta para obtener más información sobre las relaciones en su base de datos. Compílela y guárdela antes de usarla.

'*************** Code Start *****************************************************
' module name: mod_GetRelationshipType_SQL_s4p
'-------------------------------------------------------------------------------
' Purpose  : get the relationship type in words with long or short descriptions
'              from a mask with flag bits
'              in MsysRelations, this is called grbit
'              in DAO, this is Relation.Attributes
' Author   : crystal (strive4peace)
' Code List: 
' This code: 
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Mark changes. Use at your own risk.
'-------------------------------------------------------------------------------

Public Function GetRelationshipType_s4p( _ 
   pnAttribute As Long _ 
   ,Optional pbShort As Boolean = False) _ 
   As String 

'240422 strive4peace, thanks to Adrian (NeoPa) for help with masks, 240430, 508
'return a string with the description of a relationship type
   'PARAMETERS
   ' pnAttribute is called "grbit" in MSysRelationships
   '  and is a bitmask of flags
   ' pbShort = True for a short description of each flag
   '           Default=False

   Dim sDescription As String 

   sDescription =  ""
   If pnAttribute  0 Then  'actually only positive
      'noRI, dbRelationDontEnforce =2
      If (pnAttribute And dbRelationDontEnforce) = dbRelationDontEnforce Then 
         sDescription = IIf(pbShort, "NoRI ", "No Enforce, ")   'NoIntegrity
      Else 
         sDescription = IIf(pbShort, "RI ", "Referential Integrity, ") 
         
         'Unique, dbRelationUnique =1
         If (pnAttribute And dbRelationUnique) = dbRelationUnique Then 
            sDescription = sDescription _ 
               & IIf(pbShort, "U ", "Unique, ")   '1 to 1
         End If 
         'CascadeUpdate, dbRelationUpdateCascade =256
         If (pnAttribute And dbRelationUpdateCascade) = dbRelationUpdateCascade Then 
            sDescription = sDescription _ 
               & IIf(pbShort, "CasUp ", "Cascade Update, ") 
         End If 
         'CascadeDelete, dbRelationDeleteCascade =4096
         If (pnAttribute And dbRelationDeleteCascade) = dbRelationDeleteCascade Then 
            sDescription = sDescription _ 
               & IIf(pbShort, "CasDel ", "Cascade Delete, ") 
         End If 
         'Cascade to Null, dbRelationCascadeNull = 8192
         ' constant not recognized in Access but can be defined with code
         If (pnAttribute And 8192) = 8192 Then 
            sDescription = sDescription _ 
               & IIf(pbShort, "CasNull ", "Cascade Null, ") 
         End If 
         
      End If 
   ElseIf pnAttribute = 0 Then  'zero 0
      sDescription = IIf(pbShort, "RI ", "Referential Integrity, ") 
   End If  ' pnAttribute >= 0 'no negative numbers

   'Left, dbRelationLeft =16777216
   If (pnAttribute And dbRelationLeft) = dbRelationLeft Then 
      sDescription = sDescription _ 
               & IIf(pbShort, "L ", "Left Join, ") 
   'Right, dbRelationRight =33554432
   ElseIf (pnAttribute And dbRelationRight) = dbRelationRight Then 
      sDescription = sDescription _ 
               & IIf(pbShort, "R ", "Right Join, ") 
   End If 
   'Inherited, dbRelationInherited =4
   If (pnAttribute And dbRelationInherited) = dbRelationInherited Then 
      sDescription = sDescription _ 
               & IIf(pbShort, "Inh ", "Inherited, ") 
   End If 
   
   'remove trailing character(s)
   If pbShort Then  ' space
      sDescription = Left(sDescription,Len(sDescription) - 1) 
   Else  ' comma and space
      sDescription = Left(sDescription,Len(sDescription) - 2) 
   End If 
   
   'string with descriptions
   GetRelationshipType_s4p = sDescription 

End Function 

'*************** Code End *******************************************************

‘ El código se generó con colores utilizando el complemento gratuito Color Code para Access