'TITLE: ATTRIBUTE BINDING MACRO.BAS 'DESCRIPTION: This macro lists all the unbound attributes/columns ' of all the models (logical and all physicals) and domains. The ' attributes can then be bounded to any of listed domains by ' pressing the "Bind" button. 'DATE: 5/3/2001 'AUTHOR: Jason Tiret 'CONTACT: http://support.embarcadero.com/ 'COMPANY: Embarcadero Technologies Option Explicit Dim AttributeArray() As String Dim DomainArray() As String Dim AttributeIndx As Integer Dim DomainIndx As Integer Dim DomainCount As Integer Function SetupAttributes() Dim MyModel As Model Dim MyDiagram As Diagram Dim MyEntity As Entity Dim MyAttribute As AttributeObj Dim DomainName As String Dim AttributeName As String Dim i As Integer Dim MyDictionary As Dictionary Dim AttrCount As Integer Dim MyDomain As Domain Dim fk_count As Integer 'Set ER variables Set MyDiagram = DiagramManager.ActiveDiagram Set MyDictionary = MyDiagram.Dictionary Debug.Clear ReDim AttributeArray(0) AttrCount = 0 i = 0 fk_count = 0 For Each MyModel In MyDiagram.Models For Each MyEntity In MyModel.Entities If MyEntity.Attributes.Count <> 0 Then AttrCount = AttrCount + MyEntity.Attributes.Count ReDim Preserve AttributeArray(0 To AttrCount - 1) For Each MyAttribute In MyEntity.Attributes If MyAttribute.DomainId = 0 And MyAttribute.ForeignKey = False Then If MyModel.Logical = True Then AttributeArray(i) = "Logical -- " & MyEntity.EntityName & " -- " & MyAttribute.AttributeName Else AttributeArray(i) = MyModel.Name & " -- " & MyEntity.TableName & " -- " & MyAttribute.ColumnName End If i = i + 1 Else fk_count = fk_count + 1 End If Next MyAttribute AttrCount = i End If Next MyEntity Next MyModel Debug.Print "AttrCount= " & AttrCount + fk_count DomainCount = MyDictionary.Domains.Count If DomainCount = 0 Then ReDim DomainArray(0) DomainArray(0) = "No Domains in Dictionary." Else ReDim DomainArray(0 To DomainCount - 1) i = 0 For Each MyDomain In MyDictionary.Domains DomainArray(i) = MyDomain.Name i = i + 1 Next MyDomain dhQuickSort DomainArray() End If End Function Sub Main SetupAttributes() Begin Dialog UserDialog 720,350,"Attribute Binding Macro",.MyDialogFunction ' %GRID:10,7,1,1 ListBox 30,35,180,245,DomainArray(),.Domains ListBox 250,35,440,252,AttributeArray(),.Attributes Text 30,14,90,14,"Domains:",.Text1 Text 250,14,430,14,"Attributes (Format: ModelName -- EntityName -- AttributeName):",.Text2 OKButton 360,301,140,35 PushButton 540,301,120,35,"Bind",.Bind End Dialog Dim dlg As UserDialog Dialog dlg End Sub
Rem See DialogFunc help topic for more information. Private Function MyDialogFunction(DlgItem$, Action%, SuppValue&) As Boolean Dim Mo As Model Dim Diag As Diagram Dim Attr As AttributeObj Dim Ent As Entity Dim dic As Dictionary Dim dom As Domain Dim EntityName As String Dim AttributeName As String Dim ModelName As String Dim Idx As Integer Dim PrvIdx As Integer Dim Length As Integer Dim DomainName As String Dim Label As String Set Diag = DiagramManager.ActiveDiagram Select Case Action% Case 1 ' Dialog box initialization Case 2 ' Value changing or button pressed Debug.Print DlgItem & " " & SuppValue If DlgItem = "Attributes" Then AttributeIndx = SuppValue ElseIf DlgItem = "Domains" Then DomainIndx = SuppValue ElseIf DlgItem = "Bind" Then If DomainCount = 0 Then MsgBox("No Domains are in the Dictionary",0,"Error!") ElseIf AttributeIndx <> -1 Then Debug.Print AttributeIndx Label = AttributeArray(AttributeIndx) Debug.Print Label 'First, get the model name. Idx = InStr(1, Label, " -- ") Debug.Print Idx ModelName = Left(Label, Idx - 1) Debug.Print ModelName 'Second, get the entity name. PrvIdx = Idx + 6 Idx = InStr(PrvIdx, Label, " -- ") Length = Idx - PrvIdx EntityName = Mid(Label, PrvIdx, Length) 'Last, get the attribute name. Length = Len(Label) Length = Length - Idx - 5 AttributeName = Right(Label, Length) 'Now, get the model object from the model name. Set Mo = Diag.Models.Item(ModelName) 'Get the entity from the entity name. Set Ent = Mo.Entities.Item(EntityName) 'Get the attribute from the attribute name. Set Attr = Ent.Attributes.Item(AttributeName) 'Get the domain associated with the one selected DomainName = DomainArray(DomainIndx) Set dom = Diag.Dictionary.Domains.Item(DomainName) Attr.DomainId = dom.ID SetupAttributes() DlgListBoxArray("Attributes", AttributeArray()) AttributeIndx = -1 Else MsgBox("Please select an Attribute.") End If MyDialogFunction = True ' Prevent button press from closing the dialog box End If Case 3 ' TextBox or ComboBox text changed Case 4 ' Focus changed Case 5 ' Idle Rem MyDialogFunction = True ' Continue getting idle actions Case 6 ' Function key End Select End Function ' **The following code is taken from the specified book. It has been modified ' **to perform a case insensitive sort. ' From "VBA Developer's Handbook" ' by Ken Getz and Mike Gilbert ' Copyright 1997; Sybex, Inc. All rights reserved. ' Quicksort for simple data types. ' Indicate that a parameter is missing. Const dhcMissing = -2 Sub dhQuickSort(varArray As Variant,Optional intLeft As Integer, Optional intRight As Integer) ' From "VBA Developer's Handbook" ' by Ken Getz and Mike Gilbert ' Copyright 1997; Sybex, Inc. All rights reserved. ' Entry point for sorting the array. ' This technique uses the recursive Quicksort ' algorithm to perform its sort. ' In: ' varArray: ' A variant pointing to an array to be sorted. ' This had better actually be an array, or the ' code will fail, miserably. You could add ' a test for this: ' If Not IsArray(varArray) Then Exit Sub ' but hey, that would slow this down, and it's ' only YOU calling this procedure. ' Make sure it's an array. It's your problem. ' intLeft: ' intRight: ' Lower and upper bounds of the array to be sorted. ' If you don't supply these values (and normally, you won't) ' the code uses the LBound and UBound functions ' to get the information. In recursive calls ' to the sort, the caller will pass this information in. ' To allow for passing integers around (instead of ' larger, slower variants), the code uses -2 to indicate ' that you've not passed a value. This means that you won't ' be able to use this mechanism to sort arrays with negative ' indexes, unless you modify this code. ' Out: ' The data in varArray will be sorted. Dim i As Integer Dim j As Integer Dim varTestVal As Variant Dim intMid As Integer If intLeft = dhcMissing Then intLeft = LBound(varArray) If intRight = dhcMissing Then intRight = UBound(varArray) If intLeft < intRight Then intMid = (intLeft + intRight) \ 2 varTestVal = UCase(varArray(intMid)) i = intLeft j = intRight Do Do While UCase(varArray(i)) < varTestVal i = i + 1 Loop Do While UCase(varArray(j)) > varTestVal j = j - 1 Loop If i <= j Then SwapElements varArray, i, j i = i + 1 j = j - 1 End If Loop Until i > j ' To optimize the sort, always sort the ' smallest segment first. If j <= intMid Then Call dhQuickSort(varArray, intLeft, j) Call dhQuickSort(varArray, i, intRight) Else Call dhQuickSort(varArray, i, intRight) Call dhQuickSort(varArray, intLeft, j) End If End If End Sub
Private Sub SwapElements(varItems As Variant, intItem1 As Integer, intItem2 As Integer) Dim varTemp As Variant varTemp = varItems(intItem2) varItems(intItem2) = varItems(intItem1) varItems(intItem1) = varTemp End Sub