'TITLE: DOMAIN BINDINGS EXPORTTO EXCEL.BAS 'DESCRIPTION: This macro exports domain bindings for all the attributes in the ' current model. The existing columns in the spread sheet must be left ' in the same format if the bindings are going to be used to import back into ' a model. Note that the attribute data type is only in the spread sheet for ' informational purposes when refactoring attibutes and columns and assigning ' them to domains. 'AUTHOR: Jason Tiret 'CONTACT: http://support.embarcadero.com/ 'DATE: 3/23/2004 'LAST UPDATE: 10/8/2004 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 enterprise_dict As Dictionary Dim dict As Dictionary Dim dom As Domain Dim dom_folder As DomainFolder Dim dictionary_list () As String Dim so As SelectedObject Dim ent As Entity Dim attr As AttributeObj Dim entdisplay As EntityDisplay ' dim dialog variables Dim active_model_loop As Boolean 'if true, user selected to loop through only active model 'if false, user selected all models Dim selected_object_loop As Boolean 'if true, macro loops through selected objects 'if false, macro loops through all objects 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 Debug.Clear Dim active_submdl_name As String Dim active_mdl_name As String ' Init the ER/Studio variables. Set diag = DiagramManager.ActiveDiagram Set mdl = diag.ActiveModel Set submdl = mdl.ActiveSubModel active_mdl_name = mdl.Name active_submdl_name = submdl.Name Debug.Print active_mdl_name Debug.Print active_submdl_name DiagramManager.EnableScreenUpdate(False) Set Excel = CreateObject("Excel.Application") Excel.Workbooks.Add curRow = 1 curCol = 1 clrBack = CLR_WHITE clrFore = CLR_BLACK clrTitleBack = CLR_GREY clrTitleFore = CLR_BLACK Begin Dialog UserDialog 530,259,"Export domain bindings",.exp_dom_handler ' %GRID:10,7,1,1 TextBox 60,42,420,70,.diag_info,1 Text 50,21,150,14,"Diagram Information:",.text1 GroupBox 60,126,420,77,"Export Scope",.GroupBox1 OptionGroup .model_sel OptionButton 100,154,90,14,"All Models",.OptionButton1 OptionButton 100,175,130,14,"Active model",.OptionButton2 OptionGroup .object_sel OptionButton 270,154,130,14,"All Objects",.OptionButton3 OptionButton 270,175,140,14,"Selected Objects",.OptionButton4 OKButton 240,217,100,21 CancelButton 370,217,100,21 End Dialog Dim dlg As UserDialog If Dialog (dlg) = -1 Then InitColumnWidth PrintColumnHeader If active_model_loop = True Then 'loop through only the active model PrintData Else 'loop through all models For Each mdl In diag.Models PrintData Next End If MsgBox("Export Complete!",,"ER/Studio") ' make Excel spread sheet visible Excel.Visible = True End If Set mdl = diag.Models.Item(active_mdl_name) Set submdl = mdl.SubModels.Item(active_submdl_name) submdl.ActivateSubModel DiagramManager.EnableScreenUpdate(True) End Sub Sub PrintData Dim bHideFont As Boolean bHideFont = False If selected_object_loop = False Then 'loop throug all objects in active model For Each ent In mdl.Entities For Each attr In ent.Attributes PrintRecord Next Next Else 'loop through selected objects For Each so In submdl.SelectedObjects If so.Type = 1 Then Set ent = mdl.Entities.Item(so.ID) For Each attr In ent.Attributes PrintRecord Next End If Next End If End Sub 'this routine is called by PrintData to right one record to the spread sheet. 'there are no parameters associated with it. The diagram variables are initialized 'with in the Sub Main routine. Sub PrintRecord 'find the domain and dictionary 'first check local Set dict = diag.Dictionary Set dom = dict.Domains.Item(attr.DomainId) If dom Is Nothing Then 'look through the enterprise dictionaries For Each dict In diag.EnterpriseDataDictionaries Set dom = dict.Domains.Item(attr.DomainId) If dom Is Nothing Then 'continue... Else Exit For 'domain is found exit the loop with the active dictionary and domain End If Next End If 'output the diagram name to the spread sheet PrintCell diag.ProjectName, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False 'output the model name to the spreadsheet PrintCell mdl.Name, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False 'output the entity or table name to the spread sheet dependending on the type of the model If mdl.Logical = True Then PrintCell ent.EntityName, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False Else PrintCell ent.TableName, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False End If 'output the attribute or column name to the spread sheet depending on the type of the model If mdl.Logical = True Then 'print attribute name if there is no role name If attr.HasLogicalRoleName = False Then PrintCell attr.AttributeName, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False Else 'print rolename if there is one PrintCell attr.LogicalRoleName, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False End If Else 'use physical name 'print column name if there is no role name If attr.HasRoleName = False Then PrintCell attr.ColumnName, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False Else 'print rolename if there is one PrintCell attr.RoleName, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False End If End If 'output attribute data type PrintCell attr.Datatype, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False 'output attribute datatype length If attr.DataLength < 0 Then PrintCell "", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False Else PrintCell attr.DataLength, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False End If 'output attribute datatype scale If attr.DataScale < 0 Then PrintCell "", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False Else PrintCell attr.DataScale, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False End If 'output domain name to the spread sheet If dom Is Nothing Then PrintCell "", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False Else PrintCell dom.Name, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False End If 'output the dictionary name to the spreadsheet If dom Is Nothing Then PrintCell "", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False Else PrintCell dict.Name, curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, False End If curRow = curRow + 1 curCol = 1 End Sub ' Initialize the column width. Sub InitColumnWidth Dim count As Integer count = 9 'initialize column widths For j = 1 To count Excel.Cells(1, j).ColumnWidth = 30 Next j Excel.cells(1,5).columnwidth = 20 'set datatype column width Excel.cells(1,6).columnwidth = 5 'set datatype length column width Excel.cells(1,7).columnwidth = 5 'set datatype scale column width End Sub ' Print the column header. Only print headers when value is true in options array. Sub PrintColumnHeader PrintCell "Diagram", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True PrintCell "Model", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True PrintCell "Entity/Table", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True PrintCell "Attribute/Column", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True PrintCell "Attribute Datatype", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True PrintCell "Attribute Datatype Length", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True PrintCell "Attribute Datatype Scale", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True PrintCell "Domain", curRow, curCol, 0, 1, clrTitleFore, clrTitleBack, 10, True PrintCell "Dictionary", 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 Function entitiesSelected() As Boolean Dim selObj As SelectedObject If submdl.SelectedObjects.Count > 0 Then For Each selObj In submdl.SelectedObjects If selObj.Type=1 Then entitiesSelected = True Exit Function End If Next End If entitiesSelected = False End Function
Rem See DialogFunc help topic for more information. Private Function exp_dom_handler(DlgItem$, Action%, SuppValue&) As Boolean Select Case Action% Case 1 ' Dialog box initialization Dim sel_objects As String Dim mdl_type As String If entitiesSelected = False Then sel_objects = "NO" Else sel_objects = "YES" End If If mdl.Logical = True Then mdl_type = "LOGICAL" Else mdl_type = "PHYSICAL" End If 'populate text box in the dialog with some information about what will be exported DlgText diag_info, "Diagram: " & diag.ProjectName & vbCrLf & "Model Name: " & mdl.Name & vbCrLf & "Model Type: " & mdl_type & vbCrLf & "Active Model: " & submdl.Name & vbCrLf & "Selected Objects: " & sel_objects DlgValue "model_sel",0 DlgEnable "OptionButton4", False Case 2 ' Value changing or button pressed If DlgItem = "model_sel" Then If DlgValue("model_sel") = 0 Then DlgValue "object_sel", 0 DlgEnable "OptionButton4", False ElseIf DlgValue("model_sel") = 1 And entitiesSelected = True Then DlgEnable "OptionButton4", True End If active_model_loop = DlgValue("model_sel") Debug.Print "active_model_loop = " & active_model_loop selected_object_loop = DlgValue("object_sel") Debug.Print "selected_object_loop = " & selected_object_loop ElseIf DlgItem = "object_sel" Then active_model_loop = DlgValue("model_sel") Debug.Print "active_model_loop = " & active_model_loop selected_object_loop = DlgValue("object_sel") Debug.Print "selected_object_loop = " & selected_object_loop End If Rem exp_dom_handler = True ' Prevent button press from closing the dialog box Case 3 ' TextBox or ComboBox text changed Case 4 ' Focus changed Case 5 ' Idle Rem exp_dom_handler = True ' Continue getting idle actions Case 6 ' Function key End Select End Function