'TITLE: NAME FOREIGN CONSTRAINTS
'DESCRIPTION: This macro will prompt the user with a dialog to
'specify the naming convention for Foreign Constraints. It will
'then name all the constraints using the parent and child table names.
'It will also make sure the name is unique by adding an index for the
'last characters of duplicate names.
'INPUT:
' MAXIMUM CHARACTERS: This is the max limit of the number of characters
' For the entire constraint Name. Not required. Can be specified even if
' truncation option is None.
' TRUNCATE NUMBER: This limits the number of characters in both the parent and
' child part of the relationship to the number specified.
' PREFIX: This is the prefix for the relationship name
' SEPARATOR: This goes between the parent and child part of the relatioship name.
' SUFFIX: This is the suffix for the relationship name.
'CREATE DATE: 11/19/2000
'LAST UPDATE: 1/4/2002
Sub Main
Dim ParTable As String
Dim chiTable As String
Dim separator As String
Dim prefix As String
Dim sufix As String
Dim mdl As Model
Dim diag As Diagram
Dim truncation As Integer
Dim maxchs As Integer
Dim relation As Relationship
Dim RName As String
Dim C As Integer
Dim ind As Integer
Dim suf As String
' set er variables
Set diag = DiagramManager.ActiveDiagram
Set mdl = diag.ActiveModel
Begin Dialog UserDialog 660,350,"Foreign Constraint Naming Macro" ' %GRID:10,7,1,1
Text 50,21,90,14,"Order:",.Text1
CheckBox 150,203,90,14,"P&refix:",.chbxPrefix
CheckBox 150,259,90,14,"&Suffix:",.chbxSuffix
CheckBox 150,231,100,14,"S&eparator:",.chbxseparator
Text 50,84,160,14,"Truncation:",.Text2
Text 50,182,90,14,"Additions:",.Text3
OptionGroup .Order
OptionButton 270,35,160,14,"&Parent Then Child",.OptionButton1
OptionButton 270,56,140,14,"&Child Then Parent",.OptionButton2
OptionButton 130,35,110,14,"Parent Only",.OptionButton5
OptionButton 130,56,90,14,"Child Only",.OptionButton6
OptionGroup .Trunc
OptionButton 80,140,90,14,"&None",.OptionButton3
OptionButton 80,161,400,14,"&Use only this many characters of the Parent or Child name:",.OptionButton4
TextBox 490,154,90,21,.numchars
TextBox 310,196,90,21,.prefix
TextBox 310,224,90,21,.separator
TextBox 310,252,90,21,.suffix
OKButton 330,301,120,28
CancelButton 470,301,120,28
Text 160,98,260,14,"Max characters for entire FK name:",.Text5
TextBox 490,112,90,21,.MaxChars
Text 160,119,310,14,"(Can be specified even when checking ""None"".)",.Text4
End Dialog
Dim dlg As UserDialog
If Dialog(dlg) = -1 Then
'declare an array to check for duplictate relations
C = mdl.Relationships.Count
ReDim Rships(1 To C) As String
Dim rels As Variant
rels = Rships
ind = 1
For Each relation In mdl.Relationships
ParTable = relation.ParentEntity.TableName
chiTable = relation.ChildEntity.TableName
'Remove spaces from table names
ParTable = Replace(ParTable," ","")
chiTable = Replace(chiTable," ","")
If dlg.trunc = 1 And dlg.numchars <> Empty Then 'truncate Left
'truncate names of tables
truncate = Abs(CInt(dlg.numchars))
ParTable = Left(ParTable, truncate)
chiTable = Left(chiTable, truncate)
End If
prefix = dlg.prefix
suffix = dlg.suffix
separator = dlg.separator
'choose order, O = parent first, 1 = child first, 2 = parent only, 3 = child only
If dlg.Order = 0 Then
'Additions
RName = ""
'Add prefix if option is checked
If dlg.chbxprefix = 1 Then
RName = prefix
End If
RName = RName & ParTable
'Add separator if option is checked
If dlg.chbxseparator Then
RName = RName & separator
End If
RName = RName & chiTable
'Add suffix if option is checked
If dlg.chbxsuffix Then
RName = RName & suffix
End If
ElseIf dlg.order = 1 Then
'Additions
RName = ""
'Add prefix if option is checked
If dlg.chbxprefix = 1 Then
RName = prefix
End If
RName = RName & chiTable
'Add separator if option is checked
If dlg.chbxseparator = 1 Then
RName = RName & separator
End If
RName = RName & ParTable
'Add suffix if option is checked
If dlg.chbxsuffix = 1 Then
RName = RName & suffix
End If
ElseIf dlg.order = 2 Then
RName = ""
'Add prefix if option is checked
If dlg.chbxprefix = 1 Then
RName = prefix
End If
RName = RName & ParTable
'Add prefix if option is checked
If dlg.chbxsuffix = 1 Then
RName = RName & suffix
End If
Else 'dlg.order = 3
RName = ""
'add prefix if option is checked
If dlg.chbxprefix = 1 Then
RName = prefix
End If
RName = RName & chiTable
'add suffix if option is checked
If dlg.chbxsuffix = 1 Then
RName = RName & suffix
End If
End If
'truncate Name to max chars specified
If dlg.maxchars <> Empty Then
maxchs = Abs(CInt(dlg.maxchars))
RName = Left(RName, maxchs)
End If
'check if there is duplicate and change last couple characters
If checkdups(rels, RName, ind) = True Then
'add unique index to last of the relationship name
suf = Str(ind)
RName = Left(RName,(Len(RName) - Len(suf)))
RName = RName & suf
RName = Replace(RName," ","")
End If
relation.Name = RName
rels(ind) = RName
ind = ind + 1
Next relation
End If ' dialog
End Sub
Function checkdups ( R As Variant, RelName As String, C As Integer ) As Boolean
Dim flag As Boolean
flag = False
For i = 1 To C
If R(i) = RelName Then
flag = True
End If
Next i
checkdups = flag
End Function