'MACRO TITLE: EXPORT RELATIONSHIP INFO TO EXCEL.BAS 'This macro generates a foreign key column report for the active 'model in ER/Studio. Each foreign key column will have an entry 'in the spread sheet. The spread sheet can be used to apply naming 'standards to Relationships/foreign constraints. The new relationship 'name can be entered into the "New Relationship Name column" and 'imported back into ER/Studio with the "Import Relationship Names" 'macro. ' REQUIREMENT: You must have MS Excel 97 or later installed ' AUTHOR: Jason Tiret 'CONTACT: http://support.embarcadero.com/ ' LAST UPDATE: 5/6/2003 Dim curRow As Integer Dim curCol As Integer Dim clrBack As Variant Dim clrFore As Variant Dim clrTitleBack As Variant Dim clrTitleFore As Variant ' Dim MS Excel variables. Dim Excel As Object ' Dim ER/Studio variables. Dim diag As Diagram Dim mdl As Model Dim submdl As SubModel Dim so As SelectedObject Dim ent As Entity Dim attr As AttributeObj Dim rel As Relationship Dim reldisp As RelationshipDisplay Dim fkcol As FKColumnPair Dim fkcount As Integer 'dup check Dim FKduplicates() As String 'dup check Public Const CLR_WHITE = RGB(255, 255, 255) Public Const CLR_BLACK = RGB(0, 0, 0) Public Const CLR_GREY = RGB(192, 192, 192) Public Const CLR_TEAL = RGB(0, 128, 128) Sub Main ' Init the ER/Studio variables. Set diag = DiagramManager.ActiveDiagram Set mdl = diag.ActiveModel Set submdl = mdl.ActiveSubModel curRow = 1 curCol = 1 Debug.Clear clrBack = CLR_WHITE clrFore = CLR_BLACK clrTitleBack = CLR_GREY clrTitleFore = CLR_BLACK ' Create Excel workbook. Set Excel = CreateObject("Excel.Application") Excel.Workbooks.Add InitColumnWidth PrintColumnHeader PrintData MsgBox("Export Complete!",,"ER/Studio") 'make Excel visible Excel.Visible = True End Sub Sub PrintData Dim bHideFont As Boolean bHideFont = False Dim sequence As Integer Dim j As Integer 'dup check j = 0 'dup check fkcount = 0 'dup check sequence = 1 'loop through the relationship display objects of the current submodel For Each reldisp In submdl.RelationshipDisplays 'get the relationship object from the display object Set rel = reldisp.ParentRelationship 'provide a default name for the relationship if the relationship is unnamed If rel.Name = "" Then rel.Name = "REL_" & sequence sequence = sequence + 1 End If fkcount = fkcount + rel.FKColumnPairs.Count 'dup check ReDim Preserve FKduplicates(0 To fkcount) As String 'dup check Debug.Print "Relationship: " & rel.Name 'dup check Debug.Print "FKs: " & fkcount 'dup check Debug.Print "size of FK Array: " & UBound(FKduplicates) 'dup check 'loop through the columns of the child entity table For i = 1 To rel.ChildEntity.Attributes.Count 'loop through the FK columns of each relationship For Each fkcol In rel.FKColumnPairs 'match the FK column's sequence number with the attribute sequence number If fkcol.SequenceNo = i Then If checkFKduplicates(rel.Name & fkcol.ChildAttribute.ColumnName) = 0 Then 'dup check 'output Relationship information to Excel PrintCell rel.Name, curRow, curCol, 0, 1, clrFore, clrBack, 10, False PrintCell rel.ParentEntity.TableName, curRow, curCol, 0, 1, clrFore, clrBack, 10, False PrintCell rel.ChildEntity.TableName, curRow, curCol, 0, 1, clrFore, clrBack, 10, False PrintCell fkcol.ChildAttribute.ColumnName, curRow, curCol, 0, 1, clrFore, clrBack, 10, False curRow = curRow + 1 curCol = 1 bHideFont = False FKduplicates(j) = rel.Name & fkcol.ChildAttribute.ColumnName 'dup check j = j + 1 'dup check End If 'dup check End If Next Next Next End Sub ' Function to check for duplicate FK columns ' returns 1 if duplicate is found, 0 if duplicate is not found Function checkFKduplicates (input_str As String) As Integer 'dup check Dim i As Integer 'dup check For i = 0 To fkcount 'dup check If FKduplicates(i) = input_str Then 'dup check checkFKduplicates = 1 'dup check Exit Function 'dup check End If 'dup check Next 'dup check checkFKduplicate = 0 'dup check End Function 'dup check ' Initialize the column width. Sub InitColumnWidth Dim count As Integer count = 5 'initialize column widths For j = 1 To count Excel.Cells(1, j).ColumnWidth = 20 Next j End Sub ' Print the column header. Only print headers when value is true in options array. Sub PrintColumnHeader PrintCell "Parent Relationship FK Name", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True PrintCell "Parent Table Name", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True PrintCell "Child Table Name", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True PrintCell "Parent Migrated Column Name", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True PrintCell "New Parent Relationship FK Name", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True curRow = curRow + 1 curCol = 1 End Sub ' Print a cell Sub PrintCell(value As String, row As Integer, col As Integer, rowInc As Integer, colInc As Integer, clrFore As Variant, clrBack As Variant, szFont As Integer, bBold As Boolean) Excel.Cells(row, col).Value = value Excel.Cells(row, col).Font.Bold = bBold Excel.Cells(row, col).Font.Color = clrFore Excel.Cells(row, col).Font.Size = szFont curRow = curRow + rowInc curCol = curCol + colInc End Sub