'TITLE: GENERATE CONSTRAINTS FROM REFERENCE VALUES 'DESCRIPTION: This macro generates constraints from the defined ' reference values. The reference values must be defined in the ' data dictionary of ER/Studio. The macro can select from bound ' attributes, all attributes, bound domains or all domains. This ' is chosen with the radio buttons at the bottom of the dialog. ' the constraint will be inserted in the check constraint/rule ' tab of the domain or attribute. 'MODIFY DATE: 11/25/2002 'ER/Studio variables Dim ersMdl As Model Dim ersDiag As Diagram Dim ersEnt As Entity Dim ersAttr As AttributeObj Dim ersRefVal As ReferenceValue Dim ersDict As Dictionary Dim ersDom As Domain Dim ersUDT As UserDatatype 'Dialog Array variables Dim arrRefVals() As String Dim arrAvailableAttrs() As String Dim arrSelectedAttrs() As String Dim arrAvailAttrsIndx As Integer Dim arrSelAttrsIndx As Integer 'count variables Dim allattrcount As Integer Dim boundattrcount As Integer Dim domaincount As Integer Type AttrPair tblname As String attrname As String refvalid As Integer End Type Type DomPair domName As String refvalid As Integer End Type Dim AllAttrPairs() As AttrPair Dim boundAttrPairs() As AttrPair Dim AllDomains() As DomPair Dim AvailCurIndx As Integer Dim SelCurIndx As Integer Dim RefCurIndx As Integer Sub GetRefVals Dim i As Integer i = 0 If ersDict.ReferenceValues.Count <> 0 Then ReDim arrRefVals (0 To ersDict.ReferenceValues.Count - 1) As String For Each ersRefVal In ersDict.ReferenceValues arrRefVals(i) = ersRefVal.Name Debug.Print ersRefVal.ID i = i + 1 Next Else ReDim arrRefVals (0) End If End Sub Function genConstraint (rvName As String) As String Dim constraint As String Dim vp As ValuePair Dim rv As ReferenceValue Set rv = ersDiag.Dictionary.ReferenceValues.Item(rvName) If Not(rv Is Nothing) Then If rv.IsRange = True Then If rv.IsNotBetween = True Then constraint = "@var < " & rv.MinValue & " AND @var > " & rv.MaxValue Else constraint = "@var >= " & rv.MinValue & " AND @var <= " & rv.MaxValue End If Else If rv.IsNotBetween = True Then constraint = "@var NOT IN (" For Each vp In rv.Values If IsNumeric(vp.Value) Or hasQuotes(vp.Value) Then constraint = constraint & vp.Value & ", " ElseIf Not(hasQuotes(vp.Value)) Then constraint = constraint & "'" & vp.Value & "'" & ", " End If Next Left(constraint, Len(constraint) - 2) constraint = constraint & ")" Else constraint = "@var IN (" For Each vp In rv.Values If IsNumeric(vp.Value) Or hasQuotes(vp.Value) Then constraint = constraint & vp.Value & ", " ElseIf Not(hasQuotes(vp.Value)) Then constraint = constraint & "'" & vp.Value & "'" & ", " End If Next constraint = Left(constraint, Len(constraint) - 2) constraint = constraint & ")" End If End If genConstraint = constraint Else genConstraint = "" End If End Function Function hasQuotes (st As String) As Boolean If Left(st, 1) = "'" And Right(st, 1) = "'" Then hasQuotes = True ElseIf Left(st, 1) = """" And Right(st, 1) = """" Then hasQuotes = True Else hasQuotes = False End If End Function Function applyConstraint (tbl As String, col As String, con As String) Dim ent As Entity Dim att As AttributeObj Set ent = ersMdl.Entities.Item(tbl) Set att = ent.Attributes.Item(col) att.CheckConstraint = con End Function Function applyConstraintDomain (d As String, con As String) Dim dom As Domain Set dom = ersDict.Domains.Item(d) dom.CheckConstraint = con End Function 'This function is used to initialize the passed-in array with all 'the tables in the physical model. It will fill the target array 'when the AddAll and RemoveAll buttons in the dialog are pressed. Function SetupBoundAttrArray(attrs() As String, refname As String) Debug.Print "SetupBoundAttrArray" Dim i,j,count As Integer count = 0 For i = 0 To boundattrcount - 1 Set ersRefVal = ersDiag.Dictionary.ReferenceValues.Item(refname) If ersRefVal.ID = boundAttrPairs(i).refvalid Then count = count + 1 End If Next Debug.Print "count = " & count i = 0 If count <= 0 Then ReDim attrs(0) As String Else ReDim attrs (0 To count - 1) As String j = 0 'Refresh Array with table names For i = 0 To boundattrcount - 1 Set ersRefVal = ersDiag.Dictionary.ReferenceValues.Item(refname) If ersRefVal.ID = boundAttrPairs(i).refvalid Then attrs(j) = boundAttrPairs(i).tblName & " -- " & boundAttrPairs(i).attrName Debug.Print vbTab & i & " = " & attrs(j) j = j + 1 End If Next End If End Function 'This function clears the passed-in array of all the names. It clears the 'source array when the AddAll and RemoveAll buttons are pressed. Function ClearAttrArray(attrs As Variant) If allattrcount > domaincount Then ReDim attrs(0 To allattrcount) As String Else ReDim attrs(0 To domaincount) As String End If End Function 'This function is used to move single tables between the listboxes. It 'will add tables to the front of the target array and pad the back of the 'source array with blank entries Function MoveAttr (source As Variant, target As Variant, source_indx As Integer) Dim s_count As Integer 'upper bound of the source array Dim t_count As Integer 'upper bound of the target array Dim i As Integer s_count = UBound(source) t_count = UBound(target) - 1 Debug.Print "t_count = " & t_count 'move all the entries back one slot in the target array to make 'room for the new entry For i = t_count To 0 Step -1 target(i+1) = target(i) Debug.Print "target(" & i & ") = " & target(i) Next i 'add the new entry target(0) = source(source_indx) Debug.Print source(source_indx) & ", index = " & source_indx 'move all the entries after the vacant slot up one slot to fill the hole For i = source_indx + 1 To s_count source(i-1) = source(i) Next i 'pad the last entry with a null string source(s_count) = "" End Function Function loadBoundAttrs boundattrcount = 0 For Each ersEnt In ersMdl.Entities For Each ersAttr In ersEnt.Attributes If Not(ersAttr.GetReferenceValue Is Nothing) Then Debug.Print ersAttr.GetReferenceValue.Name boundattrcount = boundattrcount + 1 End If Next Next If boundattrcount > 0 Then ReDim boundAttrPairs (0 To boundattrcount - 1) As AttrPair For Each ersEnt In ersMdl.Entities If ersEnt.Attributes.Count <> 0 Then For Each ersAttr In ersEnt.Attributes If Not(ersAttr.GetReferenceValue Is Nothing) Then If ersMdl.Logical = True Then boundAttrPairs(i).tblName = ersEnt.EntityName boundAttrPairs(i).attrname = ersAttr.AttributeName Debug.Print "att name = " & boundAttrPairs(i).attrname Else boundAttrPairs(i).tblName = ersEnt.TableName boundAttrPairs(i).attrname = ersAttr.ColumnName Debug.Print "att name = " & boundAttrPairs(i).attrname End If Set ersRefVal = ersAttr.GetReferenceValue boundAttrPairs(i).refvalid = ersRefVal.ID i = i + 1 End If Next End If Next End If End Function Function loadAllAttrs allattrcount = 0 For Each ersEnt In ersMdl.Entities allattrcount = allattrcount + ersEnt.Attributes.Count Next ReDim AllAttrPairs ( 0 To allattrcount - 1) As AttrPair For Each ersEnt In ersMdl.Entities For Each ersAttr In ersEnt.Attributes If ersMdl.Logical = True Then AllAttrPairs(i).tblName = ersEnt.EntityName AllAttrPairs(i).attrname = ersAttr.AttributeName Debug.Print "att name = " & AllAttrPairs(i).attrname Else AllAttrPairs(i).tblName = ersEnt.TableName AllAttrPairs(i).attrname = ersAttr.ColumnName Debug.Print "att name = " & AllAttrPairs(i).attrname End If i = i + 1 Next Next End Function Function setupAllAttrArray ( attrs() As String ) ReDim attrs (0 To allattrcount - 1) As String Dim i As Integer For i = 0 To allattrcount - 1 attrs(i) = AllAttrPairs(i).tblName & " -- " & AllAttrPairs(i).attrName Next End Function Function loadDomainArray () Dim dom As Domain Dim i As Integer i = 0 domaincount = ersDict.Domains.Count If ersDict.Domains.Count <> 0 Then ReDim AllDomains(0 To domaincount - 1) As DomPair For Each dom In ersDict.Domains AllDomains(i).domName = dom.Name AllDomains(i).refvalid = dom.ReferenceValueId i = i + 1 Next End If End Function Function setupAllDomains ( doms() As String ) Dim i As Integer Dim count As Integer ReDim doms(0 To domaincount) As String For i = 0 To domaincount - 1 doms(i) = AllDomains(i).domName Next End Function Function setupBoundDomains ( doms() As String, refname As String ) Dim i, j As Integer Dim count As Integer count = 0 Set ersRefVal = ersDiag.Dictionary.ReferenceValues.Item(refname) For i = 0 To domaincount - 1 If ersRefVal.ID = AllDomains(i).refvalid Then count = count + 1 End If Next If count <= 0 Then ReDim doms(0) As String Else ReDim doms(0 To count - 1) As String j = 0 For i = 0 To domaincount - 1 Set ersRefVal = ersDiag.Dictionary.ReferenceValues.Item(refname) If ersRefVal.ID = AllDomains(i).refvalid Then doms(j) = AllDomains(i).domName j = j + 1 End If Next End If End Function Sub Main Debug.Clear Set ersDiag = DiagramManager.ActiveDiagram Set ersMdl = ersDiag.ActiveModel Set ersDict = ersDiag.Dictionary loadDomainArray loadBoundAttrs loadAllAttrs GetRefVals ClearAttrArray arrSelectedAttrs SetupBoundAttrArray arrAvailableAttrs, arrRefVals(0) AvailCurIndx = 0 SelCurIndx = 0 If ersDiag.Dictionary.ReferenceValues.Count = 0 Then MsgBox("There are no Reference Values in the Data Dictionary.",,"ER/Studio") End If Begin Dialog UserDialog 800,497,"Generate Constraints",.GenConstraintDialogFunc ' %GRID:10,7,1,1 Text 30,35,120,14,"Reference Values:",.Text1 ListBox 40,154,280,161,arrAvailableAttrs(),.Available ListBox 440,154,310,161,arrSelectedAttrs(),.Selected PushButton 350,168,60,21,">>",.AddAll PushButton 350,196,60,21,">",.AddOne PushButton 350,252,60,21,"<",.RemoveOne PushButton 350,280,60,21,"<<",.RemoveAll TextBox 200,343,460,63,.ConstraintValue,1 Text 100,343,70,14,"Constraint:",.Text2 Text 40,133,120,14,"Bound Columns:",.Text3 Text 440,133,120,14,"Applied Columns:",.Text4 PushButton 500,448,110,28,"Apply",.Apply ListBox 180,28,370,98,arrRefVals(),.RefVals PushButton 640,448,110,28,"Close",.CloseDlg GroupBox 30,420,300,63,"Load Choice",.GroupBox1 OptionGroup .LoadChoice OptionButton 50,441,140,14,"Bound Attributes",.OptionButton1 OptionButton 50,462,130,14,"All Attributes",.OptionButton2 OptionButton 190,441,130,14,"Bound Domains",.OptionButton3 OptionButton 190,462,90,14,"Domains",.OptionButton4 End Dialog Dim dlg As UserDialog dlg.constraintvalue = genConstraint(arrRefVals(0)) Dialog dlg End Sub
Rem See DialogFunc help topic for more information. Private Function GenConstraintDialogFunc(DlgItem$, Action%, SuppValue&) As Boolean Select Case Action% Case 1 ' Dialog box initialization Case 2 ' Value changing or button pressed If DlgItem = "RefVals" Then RefCurIndx = SuppValue ClearAttrArray arrSelectedAttrs If DlgValue("LoadChoice") = 0 Then ClearAttrArray arrAvailableAttrs SetupBoundAttrArray arrAvailableAttrs, arrRefVals(SuppValue) ElseIf DlgValue("LoadChoice") = 2 Then ClearAttrArray arrAvailableAttrs setupBoundDomains arrAvailableAttrs, arrRefVals(SuppValue) End If DlgListBoxArray "Available", arrAvailableAttrs DlgListBoxArray "Selected", arrSelectedAttrs DlgText "ConstraintValue", genConstraint(arrRefVals(SuppValue)) GenConstraintDialogFunc = True ElseIf DlgItem = "AddOne" Then If arrAvailableAttrs(AvailCurIndx) <> "" Then MoveAttr(arrAvailableAttrs, arrSelectedAttrs, AvailCurIndx) DlgListBoxArray "Available", arrAvailableAttrs() DlgListBoxArray "Selected", arrSelectedAttrs() AvailCurIndx = 0 SelCurIndx = 0 End If GenConstraintDialogFunc = True ElseIf DlgItem = "AddAll" Then If DlgValue("LoadChoice") = 0 Then SetupBoundAttrArray(arrSelectedAttrs, arrRefVals(RefCurIndx)) ElseIf DlgValue("LoadChoice") = 1 Then setupAllAttrArray(arrSelectedAttrs) ElseIf DlgValue("LoadChoice") = 2 Then setupBoundDomains(arrSelectedAttrs, arrRefVals(RefCurIndx)) Else setupAllDomains(arrSelectedAttrs) End If ClearAttrArray(arrAvailableAttrs) DlgListBoxArray "Available", arrAvailableAttrs() DlgListBoxArray "Selected", arrSelectedAttrs() GenConstraintDialogFunc = True ElseIf DlgItem = "RemoveOne" Then If arrSelectedAttrs(SelCurIndx) <> "" Then MoveAttr(arrSelectedAttrs, arrAvailableAttrs, SelCurIndx) DlgListBoxArray "Available", arrAvailableAttrs() DlgListBoxArray "Selected", arrSelectedAttrs() AvailCurIndx = 0 SelCurIndx = 0 End If GenConstraintDialogFunc = True ElseIf DlgItem = "RemoveAll" Then If DlgValue("LoadChoice") = 0 Then SetupBoundAttrArray(arrAvailableAttrs, arrRefVals(RefCurIndx)) ElseIf DlgValue("LoadChoice") = 1 Then setupAllAttrArray(arrAvailableAttrs) ElseIf DlgValue("LoadChoice") = 2 Then setupBoundDomains(arrAvailableAttrs, arrRefVals(RefCurIndx)) Else setupAllDomains(arrAvailableAttrs) End If ClearAttrArray(arrSelectedAttrs) DlgListBoxArray "Available", arrAvailableAttrs() DlgListBoxArray "Selected", arrSelectedAttrs() GenConstraintDialogFunc = True ElseIf DlgItem = "Available" Then AvailCurIndx = SuppValue Debug.Print AvailCurIndx GenConstraintDialogFunc = True ElseIf DlgItem = "Selected" Then SelCurIndx = SuppValue Debug.Print SelCurIndx GenConstraintDialogFunc = True ElseIf DlgItem = "Apply" Then If DlgValue("LoadChoice") < 2 Then If UBound(arrSelectedAttrs) > 0 Then Dim tblname As String Dim attrname As String Dim Label As String Dim x As Integer Dim y As Integer Dim Length As Integer Dim ixname As String For i = 0 To UBound(arrSelectedAttrs) If arrSelectedAttrs(i) <> "" Then 'Get table name Label = arrSelectedAttrs(i) x = InStr(1, Label, " -- ") - 1 tblname = Left(Label, x) Debug.Print "tbl = " & "'" & tblname & "'" 'get attr name x = x + 6 Length = Len(Label) y = Length - x attrname = Right(Label, y) Debug.Print "attr = " & "'" & attrname & "'" Set ersEnt = ersMdl.Entities.Item(tblname) Set ersAttr = ersEnt.Attributes.Item(attrname) ersAttr.CheckConstraint = DlgText("ConstraintValue") End If Next End If Else If UBound(arrSelectedAttrs) > 0 Then For i = 0 To UBound(arrSelectedAttrs) If arrSelectedAttrs(i) <> "" Then Set ersDom = ersDict.Domains.Item(arrSelectedAttrs(i)) ersDom.CheckConstraint = DlgText("ConstraintValue") Debug.Print ersDom.Name & " = " & ersDom.UserDatatypeId End If Next End If End If ClearAttrArray arrSelectedAttrs DlgListBoxArray "Selected", arrSelectedAttrs() GenConstraintDialogFunc = True ElseIf DlgItem = "LoadChoice" Then If DlgValue("LoadChoice") = 0 Then SetupBoundAttrArray arrAvailableAttrs, arrRefVals(RefCurIndx) ClearAttrArray arrSelectedAttrs DlgListBoxArray "Available", arrAvailableAttrs() DlgListBoxArray "Selected", arrSelectedAttrs() ElseIf DlgValue("LoadChoice") = 1 Then setupAllAttrArray arrAvailableAttrs ClearAttrArray arrSelectedAttrs DlgListBoxArray "Available", arrAvailableAttrs() DlgListBoxArray "Selected", arrSelectedAttrs() ElseIf DlgValue("LoadChoice") = 2 Then setupBoundDomains arrAvailableAttrs, arrRefVals(RefCurIndx) ClearAttrArray arrSelectedAttrs DlgListBoxArray "Available", arrAvailableAttrs() DlgListBoxArray "Selected", arrSelectedAttrs() Else setupAllDomains arrAvailableAttrs ClearAttrArray arrSelectedAttrs DlgListBoxArray "Available", arrAvailableAttrs() DlgListBoxArray "Selected", arrSelectedAttrs() End If End If Rem GenConstraintDialogFunc = True ' Prevent button press from closing the dialog box Case 3 ' TextBox or ComboBox text changed Case 4 ' Focus changed Case 5 ' Idle Rem GenConstraintDialogFunc = True ' Continue getting idle actions Case 6 ' Function key End Select End Function