'TITLE: IMPORT OBJECT DEFINITION AND NOTES FROM EXCEL.BAS 'DESCRIPTION: This macro will import definition and notes for ' entities, attributes, views and relationships from an ' excel spreadsheet. For the definitions and notes to imported ' into the correct fields, the spread sheet needs the be a ' certain formatt (specified below). Use "EXPORT OJBECT ' DEFINITION AND NOTES TO EXCEL" macro to get a sample file. ' Object names in the spreadsheet not found in the model will be ' ignored during the import. If a definition or note is blank ' or the same in the model as the spread sheet, it will be ' ignored. Case is ignored when comparing Object names between ' the spread sheet and the model. ' 'FORMAT: ' The respective object definitions and notes for each object are ' imported from a separate sheet in the Excel workbook. Each sheet ' must be labeled with the respective object type, i.e., "Entities", ' "Attributes", "Views", and "Relationships". The order of the ' sheets is irrelevant, but the sheets must be named as quoted ' previously. ' ' ENTITIES SHEET: ' The "Entities" sheet must have the table name in first column, ' table definitions in the second column and table notes in the ' third column. The first row with values in the sheet is ' ignored. It is reserved for column titles, i.e., "Entity Name", ' "Entity Definitions", and "Entity Notes". ' ' RELATIONSHIPS SHEET: ' The "Relationships" sheet must have the relationship name in ' first column, relationship definitions in the second column ' and relationship notes in the third column. The first row ' with values in the sheet is ignored. It is reserved for ' column titles, i.e., "Relationship Name", "Relationship ' Definitions", and "Relationship Notes". ' ' VIEWS SHEET: ' The "Views" sheet must have the view name in first column, ' view definitions in the second column and view notes in the ' third column. The first row with values in the sheet is ' ignored. It is reserved for column titles, i.e., "View Name", ' "View Definitions", and "View Notes". ' ' ATTRIBUTES SHEET: ' The "Attributes" sheet must have the attribute name in the ' first column, attribute definition in the second column, and ' entity name of the table it belongs to in the third column. ' The first row with values in the sheet is ignored. It is ' reserved for column titles, i.e., "Attribute Name", ' "Attribute Definitions", "Entity Name". ' 'AUTHOR: Jason E. Tiret 'EMAIL: jason.tiret@embarcadero.com 'DATE: 7/10/01 'LAST UPDATE: 10/8/2004 Option Explicit Type EntityDefStruct EntityName As String EntityDef As String EntityNotes As String End Type Type AttributeDefStruct AttributeName As String AttributeDef As String EntityName As String End Type Type RelationshipDefStruct RelationshipName As String RelationshipDef As String RelationshipNotes As String End Type Type ViewDefStruct ViewName As String ViewDef As String ViewNotes As String End Type 'definition arrays Dim EntityDefs() As EntityDefStruct Dim AttributeDefs() As AttributeDefStruct Dim RelationshipDefs() As RelationshipDefStruct Dim ViewDefs() As ViewDefStruct Dim modeldd() As String 'global variables Dim mdl As Model Dim diag As Diagram Dim ent As Entity Dim att As AttributeObj Dim vi As View Dim rel As Relationship Dim filename As String Dim entcount As Integer Dim attcount As Integer Dim relcount As Integer Dim viewcount As Integer Sub Main Dim excel As Object Dim entcount As Integer Dim eName As String Dim aName As String Dim rName As String Dim vName As String Dim eDef As String Dim eNote As String Dim aDef As String Dim rDef As String Dim rNote As String Dim vDef As String Dim vNote As String Dim modCount As Integer Dim i As Integer Set diag = DiagramManager.ActiveDiagram DiagramManager.EnableScreenUpdate(False) 'fill array for model drop down in the dialog modCount = diag.Models.Count ReDim modeldd (0 To modCount - 1) i = 0 For Each mdl In diag.Models modeldd(i) = mdl.Name i = i + 1 Next Debug.Clear Debug.Print diag.ActiveModel.Name Begin Dialog UserDialog 510,357,"Import Definitions From Excel",.DialogFunc ' %GRID:10,7,1,1 Text 40,14,170,14,"Path to XLS spreadsheet:",.Text1 TextBox 70,35,340,21,.path OKButton 210,322,110,21 CancelButton 350,322,110,21 GroupBox 50,84,410,189,"Import Options",.GroupBox1 Text 70,112,90,14,"Select Model",.model OptionGroup .Definitions OptionButton 70,217,220,14,"Overwrite Existing Definitions",.Overwrite OptionButton 70,238,350,14,"Append Definitions to the end of existing Definitions",.Append DropListBox 170,105,200,77,modeldd(),.ModelName PushButton 430,35,60,21,"Browse",.Browse Text 70,140,200,14,"Select Object Types",.Text3 CheckBox 90,161,140,14,"Table Definitions",.tables CheckBox 90,182,150,14,"Attribute Definitions",.Attributes CheckBox 250,161,180,14,"Relationship Definitions",.Relationships CheckBox 250,182,130,14,"View Definitions",.Views Text 50,280,370,28,"Note: Format of SpreadSheet is specified in the header of the macro. Right-click and choose edit to view.",.Text2 End Dialog Dim dlg As UserDialog start_dialog: 'start dialog If Dialog(dlg) = -1 Then 'initialize excel object and make visible Set excel = CreateObject("Excel.Application") excel.Visible = True 'this error is for an errant file path, dialog will be restarted On Error GoTo Error_handle excel.workbooks.open dlg.path 'initialize ER variables Set mdl = diag.Models.Item(modeldd(dlg.ModelName)) 'import table definitions and notes if option is checked in dialog If dlg.tables = 1 Then 'fill entity array with definitions and notes from spread sheet FillEntityDefArray(excel) 'Loop through entities to update definitions and notes For Each ent In mdl.Entities 'use logical or physical name depending on type of model If mdl.Logical = True Then eName = ent.EntityName Else eName = ent.TableName End If 'get repective note and definition from array eDef = GetEntityDef(eName) eNote = GetEntityNote(eName) 'don't update definition if it is the same as the model or if it is blank If eDef <> "" And ent.Definition <> eDef Then If dlg.definitions = 0 Then 'overwrite definition ent.Definition = eDef Else 'append definition ent.Definition = ent.Definition & vbCrLf & eDef End If End If 'don't update the note if it is the same as the model or if it is blank If eNote <> "" And ent.Note <> eNote Then If dlg.definitions = 0 Then 'overwrite note ent.Note = eNote Else 'append note ent.Note = ent.Note & vbCrLf & eNote End If End If Next End If 'import attribute definitions if option is checked in dialog If dlg.Attributes = 1 Then 'Get Attribute definitions from spreadsheet FillAttributeDefArray(excel) For Each ent In mdl.Entities 'Loop through attributes to update definitions For Each att In ent.Attributes 'use logical if model is logical, physical if model is physical If mdl.Logical = True Then eName = ent.EntityName aName = att.AttributeName Else eName = ent.TableName aName = att.ColumnName End If aDef = GetAttributeDef(eName, aName) 'don't udate definitions if spread sheet def is null or same as model def If aDef <> "" And att.Definition <> aDef Then If dlg.definitions = 0 Then att.Definition = aDef Else att.Definition = att.Definition & vbCrLf & aDef End If End If Next Next End If 'update view notes and definitions if dialog option is checked If dlg.Views = 1 Then 'get definitions and notes from the excel spread sheet FillViewDefArray(excel) 'loop through views to update definitions and notes in the model For Each vi In mdl.Views vName = vi.Name 'get view def and notes from respective arrays vDef = GetViewDef(vName) vNote = GetViewNote(vName) 'don't update the model def if it is the same as excel def or if excel def is blank If vDef <> "" And vi.Definition <> vDef Then If dlg.definitions = 0 Then vi.Definition = vDef Else vi.Definition = vi.Definition & vbCrLf & vDef End If End If 'don't update note if it is the same as excel note or if excel note is blank If vNote <> "" And vi.Notes <> vNote Then If dlg.definitions = 0 Then vi.Notes = vNote Else vi.Notes = vi.Notes & vbCrLf & vNote End If End If Next End If 'Update relationship notes and defs if dialog option is checked If dlg.Relationships = 1 Then 'get defs and notes from excel spreadsheet FillRelationshipDefArray(excel) 'loop through relationships to update defs and notes For Each rel In mdl.Relationships rName = rel.Name 'get note and def from respective arrays rDef = GetRelationshipDef(rName) rNote = GetRelationshipNote(rName) 'don't update def if it is the same as excel def or if excel def is blank If rDef <> "" And rel.Definition <> rDef Then If dlg.definitions = 0 Then 'overwrite def rel.Definition = rDef Else 'append def rel.Definition = rel.Definition & vbCrLf & rDef End If End If 'don't update note if it is the same as excel note or if excel note is blank If rNote <> "" And rel.Note <> rNote Then If dlg.definitions = 0 Then rel.Note = rNote Else rel.Note = rel.Note & vbCrLf & rNote End If End If Next End If excel.workbooks.Close excel.visible = False End If DiagramManager.EnableScreenUpdate(True) Exit Sub Error_handle: MsgBox("Please enter a valid path.",,"Error!") GoTo start_dialog End Sub 'returns Entity def from Entity def Array given an Entity name from the model Function GetEntityDef( EntityName As String ) As String Dim i As Integer For i = 2 To entcount If UCase(EntityDefs(i).EntityName) = UCase(EntityName) Then GetEntityDef = EntityDefs(i).EntityDef Exit Function End If Next GetEntityDef = "" End Function 'returns Entity def from Entity note Array given an Entity name from the model Function GetEntityNote( EntityName As String ) As String Dim i As Integer For i = 2 To entcount If UCase(EntityDefs(i).EntityName) = UCase(EntityName) Then GetEntityNote = EntityDefs(i).EntityNotes Exit Function End If Next GetEntityNote = "" End Function 'returns a relationship definitions from the relationship definition array Function GetRelationshipDef( RelName As String ) As String Dim i As Integer For i = 2 To relcount If UCase(RelationshipDefs(i).relationshipName) = UCase(RelName) Then GetRelationshipDef = RelationshipDefs(i).relationshipDef Exit Function End If Next GetRelationshipDef = "" End Function 'returns the relationship note from the relationship note array Function GetRelationshipNote( RelName As String ) As String Dim i As Integer For i = 2 To relcount If UCase(RelationshipDefs(i).RelationshipName) = UCase(RelName) Then GetRelationshipNote = RelationshipDefs(i).RelationshipNotes Exit Function End If Next GetRelationshipNote = "" End Function 'returns the View definition from the view def array Function GetViewDef( ViewName As String ) As String Dim i As Integer For i = 2 To viewcount If UCase(ViewDefs(i).viewName) = UCase(ViewName) Then GetViewDef = ViewDefs(i).viewDef Exit Function End If Next GetViewDef = "" End Function 'returns the view note from the view note array Function GetViewNote( ViewName As String ) As String Dim i As Integer For i = 2 To viewcount If UCase(ViewDefs(i).viewName) = UCase(ViewName) Then GetViewNote = ViewDefs(i).viewNotes Exit Function End If Next GetViewNote = "" End Function 'returns the attribute definition from attribute def array Function GetAttributeDef ( EntityName As String, AttributeName As String ) As String Dim i As Integer For i = 2 To attcount If UCase(AttributeDefs(i).EntityName) = UCase(EntityName) And UCase(AttributeDefs(i).AttributeName) = UCase(AttributeName) Then GetAttributeDef = AttributeDefs(i).AttributeDef Exit Function End If Next GetAttributeDef = "" End Function 'Fills the entity array with definitions and notes from the spreadsheet Function FillEntityDefArray (ex As Object) Dim sheet As Object Dim range As Object Dim i As Integer On Error GoTo Message Set sheet = ex.worksheets("Entities") Set range = sheet.usedrange entcount = range.rows.Count ReDim EntityDefs (2 To entcount) For i = 2 To entcount EntityDefs(i).EntityName = Trim(range.cells(i, 1).Value) EntityDefs(i).EntityDef = Trim(range.cells(i, 2).Value) EntityDefs(i).EntityNotes = Trim(range.cells(i, 3).Value) Debug.Print EntityDefs(i).EntityName Debug.Print EntityDefs(i).Entitydef Next Exit Function Message: MsgBox("There is no ""Entities"" sheet in the workbook or the name is invalid. Entity Definitions will be ignored.") Exit Function End Function 'Fills the attribute def array with the attribute definitions from the excel spread sheet Function FillAttributeDefArray (ex As Object) Dim sheet As Object Dim range As Object Dim i As Integer On Error GoTo AttMessage Set sheet = ex.worksheets("Attributes") Set range = sheet.usedrange attcount = range.rows.Count ReDim AttributeDefs (2 To attcount) For i = 2 To attcount AttributeDefs(i).AttributeName = Trim(range.cells(i, 1).Value) AttributeDefs(i).AttributeDef = Trim(range.cells(i, 2).Value) AttributeDefs(i).EntityName = Trim(range.cells(i, 3).Value) Debug.Print AttributeDefs(i).AttributeName Debug.Print AttributeDefs(i).attributedef Next Exit Function AttMessage: MsgBox("There is no ""Attributes"" sheet in the workbook or the name is invalid. Attribute Definitions will be ignored.") Exit Function End Function 'fills the relationship def array with the notes and definitions from the excel spread sheet Function FillRelationshipDefArray (ex As Object) Dim sheet As Object Dim range As Object Dim i As Integer On Error GoTo RelMessage Set sheet = ex.worksheets("Relationships") Set range = sheet.usedrange relcount = range.rows.Count ReDim RelationshipDefs (2 To relcount) For i = 2 To relcount RelationshipDefs(i).relationshipName = Trim(range.cells(i, 1).Value) RelationshipDefs(i).relationshipDef = Trim(range.cells(i, 2).Value) RelationshipDefs(i).relationshipNotes = Trim(range.cells(i, 3).Value) Debug.Print RelationshipDefs(i).relationshipName Debug.Print RelationshipDefs(i).relationshipdef Next Exit Function RelMessage: MsgBox("There is no ""Relationships"" sheet in the workbook or the name is invalid. Relationship Definitions will be ignored.") Exit Function End Function 'fills the view def array with the notes and definitions from the excel spread sheet. Function FillViewDefArray (ex As Object) Dim sheet As Object Dim range As Object Dim i As Integer On Error GoTo ViewMessage Set sheet = ex.worksheets("Views") Set range = sheet.usedrange viewcount = range.rows.Count ReDim ViewDefs (2 To viewcount) For i = 2 To viewcount ViewDefs(i).viewName = Trim(range.cells(i, 1).Value) ViewDefs(i).viewDef = Trim(range.cells(i, 2).Value) ViewDefs(i).viewNotes = Trim(range.cells(i, 3).Value) Debug.Print ViewDefs(i).viewName Debug.Print ViewDefs(i).viewdef Next Exit Function ViewMessage: MsgBox("There is no ""Views"" sheet in the workbook or the name is invalid. View Definitions will be ignored.") Exit Function End Function Rem See DialogFunc help topic for more information. Private Function DialogFunc(DlgItem$, Action%, SuppValue&) As Boolean
Select Case Action% Case 1 ' Dialog box initialization Case 2 ' Value changing or button pressed If DlgItem = "Browse" Then 'browse to excel file if used pushes browse button. Put path in text box. DlgText "path", GetFilePath(,"xls",,"Open SpreadSheet") DialogFunc = True ElseIf DlgItem = "OK" And DlgText("path") = "" Then 'don't exit dialog if a path is not specified MsgBox("Please enter a valid path.",,"Error!") DialogFunc = True End If Rem DialogFunc = True ' Prevent button press from closing the dialog box Case 3 ' TextBox or ComboBox text changed Case 4 ' Focus changed Case 5 ' Idle Rem DialogFunc = True ' Continue getting idle actions Case 6 ' Function key End Select End Function