'TITLE: EXPORT OBJECT DEFINITIONS AND NOTES FROM EXCEL.BAS 'DESCRIPTION: This macro will export definitions and notes for ' tables, views, relationships and attributes to Excel. The notes ' and definitions of each object are exported to different sheets ' in the workbook. The sheets are labeled "Entities", "Attibutes", ' "Views", and "Relationships". The labels must remain the same if ' the definitions and notes are going to be imported back into the ' model. The order of the sheets is irrelevant, but the format of ' each sheet must remain the same if importing is desired. 'AUTHOR: Jason Tiret 'CONTACT: http://support.embarcadero.com/ 'DATE: 7/11/01 'LAST UPDATE: 10/8/2004 'global ER variables Dim diag As Diagram Dim ent As Entity Dim rel As Relationship Dim vi As View Dim attr As AttributeObj Dim mdl As Model Dim modeldd() As String 'global count variables Dim EntCount As Integer Dim RelCount As Integer Dim ViewCount As Integer Dim AttrCount As Integer Dim overwrite As Boolean Sub Main Dim excel As Object Dim sheet As Object Dim workbook As Object ' Init the ER/Studio variables. DiagramManager.EnableScreenUpdate(False) Set diag = DiagramManager.ActiveDiagram '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 'initialize excel object Set excel = CreateObject("excel.application") Begin Dialog UserDialog 540,350,"Export Definitions to Excel",.dialogfunc ' %GRID:10,7,1,1 GroupBox 40,14,460,259,"Export Options",.GroupBox1 DropListBox 180,154,170,70,modeldd(),.model CheckBox 80,217,150,14,"Table Definitions",.tables CheckBox 80,245,150,14,"Attribute Definitions",.Attributes CheckBox 240,217,180,14,"Relationship Definitions",.Relationships CheckBox 240,245,130,14,"View Definitions",.Views OKButton 290,308,90,21 CancelButton 400,308,90,21 Text 70,161,100,14,"Choose Model:",.Text1 Text 70,189,140,14,"Select Object Types",.Text2 OptionGroup .WBchoice OptionButton 60,35,140,14,"New Workbook",.newWB OptionButton 60,56,150,14,"Existing Workbook",.existingWB Text 80,84,40,14,"Path:",.Text3 TextBox 130,77,270,21,.WBpath PushButton 410,77,70,21,"Browse",.BrowseButton OptionGroup .OverwriteChoice OptionButton 140,112,140,14,"Overwrite Entries",.overwrite OptionButton 300,112,130,14,"Append Entries",.append End Dialog Dim dlg As UserDialog start_dialog: 'Start dialog If Dialog(dlg) = -1 Then 'get model specified in options Set mdl = diag.Models.Item(modeldd(dlg.model)) If dlg.WBchoice = 0 Then 'add workbook Set workbook = excel.workbooks.Add 'initialize Excel workbook with the proper sheets initWorkBook workbook ' DiagramManager.ShowWindow 'print tables sheet if checked in dialog If dlg.tables = 1 Then 'get entities sheet Set sheet = workbook.worksheets("Entities") PrintEntityDefs sheet End If 'print attributes sheet if checked in dialog If dlg.Attributes = 1 Then 'get attributes sheet Set sheet = workbook.worksheets("Attributes") PrintAttributeDefs sheet End If 'print relationships sheet if checked in dialog If dlg.Relationships = 1 Then 'get relationships sheet Set sheet = workbook.worksheets("Relationships") PrintRelationshipDefs sheet End If 'print views sheet if checked in dialog If dlg.Views = 1 Then 'get views sheet from workbook Set sheet = workbook.worksheets("Views") PrintViewDefs sheet End If MsgBox("Export Complete!", , "ER/Studio") Else On Error GoTo Error_handle excel.workbooks.open dlg.WBpath ' DiagramManager.ShowWindow If dlg.OverwriteChoice = 0 Then overwrite = True Else overwrite = False End If If dlg.tables = 1 Then UpdateEntitySheet excel End If If dlg.Attributes = 1 Then UpdateAttributeSheet excel End If If dlg.Views = 1 Then UpdateViewSheet excel End If If dlg.Relationships = 1 Then UpdateRelationshipSheet excel End If MsgBox("Update Complete!", , "ER/Studio") End If End If excel.visible = True DiagramManager.EnableScreenUpdate(True) Exit Sub Error_handle: MsgBox("Please Enter a valid path.",vbOkOnly, "Error!") GoTo start_dialog End Sub 'Fills the entity array with definitions and notes from the spreadsheet Function UpdateEntitySheet (ex As Object) Dim sheet As Object Dim range As Object Dim i As Integer Dim unfound As Boolean Dim E_Name As String Dim ws_indx As Integer On Error GoTo Message Set sheet = ex.worksheets("Entities") Set range = sheet.usedrange unfound = True i = 2 EntCount = range.rows.Count If EntCount < 2 Then ws_indx = 2 Else ws_indx = EntCount End If Debug.Print "EntCount= " & EntCount For Each ent In mdl.Entities If mdl.Logical = True Then E_Name = ent.EntityName Else E_Name = ent.TableName End If For i = 2 To ws_indx If UCase(E_Name) = UCase(range.cells(i, 1).Value) Then unfound = False If overwrite = True And ent.Definition <> "" Then range.cells(i, 2).Value = ent.Definition ElseIf overwrite = False And ent.Definition <> range.cells(i, 2).Value Then range.cells(i, 2).Value = range.cells(i, 2).Value & " " & ent.Definition End If If overwrite = True And ent.Note <> "" Then range.cells(i, 3).Value = ent.Note ElseIf overwrite = False And ent.Note <> range.cells(i, 3).Value Then range.cells(i, 3).Value = range.cells(i, 3).Value & " " & ent.Note End If If unfound = False Then Exit For End If End If Next If unfound = True Then EntCount = EntCount + 1 range.cells(EntCount, 1) = E_Name range.cells(EntCount, 2) = ent.Definition range.cells(EntCount, 3) = ent.Note End If unfound = True 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 UpdateAttributeSheet (ex As Object) Dim sheet As Object Dim range As Object Dim i As Integer Dim unfound As Boolean Dim E_Name As String Dim A_Name As String Dim ws_indx As Integer On Error GoTo AttMessage Set sheet = ex.worksheets("Attributes") Set range = sheet.usedrange unfound = True i = 2 AttrCount = range.rows.Count If AttrCount < 2 Then ws_indx = 2 Else ws_indx = AttrCount End If Debug.Print "AttrCount= " & AttrCount For Each ent In mdl.Entities If mdl.Logical = True Then E_Name = ent.EntityName Else E_Name = ent.TableName End If For Each attr In ent.Attributes If mdl.Logical = True Then A_Name = attr.AttributeName Else A_Name = attr.ColumnName End If For i = 2 To ws_indx If UCase(A_Name) = UCase(range.cells(i, 1).Value) And UCase(E_Name) = UCase(range.cells(i, 3).Value) Then unfound = False If overwrite = True And attr.Definition <> "" Then range.cells(i, 2).Value = attr.Definition ElseIf overwrite = False And attr.Definition <> range.cells(i, 2).Value Then range.cells(i, 2).Value = range.cells(i, 2).Value & " " & attr.Definition End If If unfound = False Then Exit For End If End If Next If unfound = True Then AttrCount = AttrCount + 1 range.cells(AttrCount, 1) = A_Name range.cells(AttrCount, 2) = attr.Definition range.cells(AttrCount, 3) = E_Name End If unfound = True Next 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 UpdateRelationshipSheet (ex As Object) Dim sheet As Object Dim range As Object Dim i As Integer Dim unfound As Boolean Dim ws_indx As Integer On Error GoTo RelMessage Set sheet = ex.worksheets("Relationships") Set range = sheet.usedrange unfound = True i = 2 RelCount = range.rows.Count If RelCount < 2 Then ws_indx = 2 Else ws_indx = RelCount End If Debug.Print "RelCount= " & RelCount For Each rel In mdl.Relationships If rel.Name <> "" Then For i = 2 To ws_indx If UCase(rel.Name) = UCase(range.cells(i, 1).Value) Then unfound = False If overwrite = True And rel.Definition <> "" Then range.cells(i, 2).Value = rel.Definition ElseIf overwrite = False And rel.Definition <> range.cells(i, 2).Value Then range.cells(i, 2).Value = range.cells(i, 2).Value & " " & rel.Definition End If If overwrite = True And rel.Note <> "" Then range.cells(i, 3).Value = rel.Note ElseIf overwrite = False And rel.Note <> range.cells(i, 3).Value Then range.cells(i, 3).Value = range.cells(i, 3).Value & " " & rel.Note End If If unfound = False Then Exit For End If End If Next If unfound = True Then RelCount = RelCount + 1 range.cells(RelCount, 1) = rel.Name range.cells(RelCount, 2) = rel.Definition range.cells(RelCount, 3) = rel.Note End If End If unfound = True 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 UpdateViewSheet (ex As Object) Dim sheet As Object Dim range As Object Dim i As Integer Dim unfound As Boolean Dim V_Name As String Dim ws_indx As Integer On Error GoTo ViewMessage Set sheet = ex.worksheets("Views") Set range = sheet.usedrange unfound = True i = 2 ViewCount = range.rows.Count If ViewCount < 2 Then ws_indx = 2 Else ws_indx = ViewCount End If Debug.Print "ViewCount= " & ViewCount For Each vi In mdl.Views For i = 2 To ws_indx If UCase(vi.Name) = UCase(range.cells(i, 1).Value) Then unfound = False If overwrite = True And vi.Definition <> "" Then range.cells(i, 2).Value = vi.Definition ElseIf overwrite = False And vi.Definition <> range.cells(i, 2).Value Then range.cells(i, 2).Value = range.cells(i, 2).Value & " " & vi.Definition End If If overwrite = True And vi.Notes <> "" Then range.cells(i, 3).Value = vi.Notes ElseIf overwrite = False And vi.Notes <> range.cells(i, 3).Value Then range.cells(i, 3).Value = range.cells(i, 3).Value & " " & vi.Notes End If If unfound = False Then Exit For End If End If Next If unfound = True Then ViewCount = ViewCount + 1 range.cells(ViewCount, 1) = vi.Name range.cells(ViewCount, 2) = vi.Definition range.cells(ViewCount, 3) = vi.Notes End If unfound = True 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 'This procedure prints the entity notes and definitions to the "Entities" Sheet Sub PrintEntityDefs ( sh As Variant ) Dim i As Integer EntCount = mdl.Entities.Count i = 2 For Each ent In mdl.Entities If mdl.Logical = True Then sh.cells(i, 1).Value = ent.EntityName Else sh.cells(i, 1).Value = ent.TableName End If sh.cells(i, 2).Value = ent.Definition sh.cells(i, 3).Value = ent.Note i = i + 1 Next End Sub 'This procedure prints the attribute definitions to the "Attributes" sheet Sub PrintAttributeDefs ( sh As Variant ) Dim i As Integer i = 2 For Each ent In mdl.Entities For Each attr In ent.Attributes If mdl.Logical = True Then sh.cells(i, 1).Value = attr.AttributeName sh.cells(i, 3).Value = ent.EntityName Else sh.cells(i, 1).Value = attr.ColumnName sh.cells(i, 3).Value = ent.TableName End If sh.cells(i, 2).Value = attr.Definition i = i + 1 Next Next End Sub 'this procedure prints the relationship definitions and notes to the "Relationships" sheet Sub PrintRelationshipDefs ( sh As Variant ) Dim i As Integer i = 2 For Each rel In mdl.Relationships sh.cells(i, 1).Value = rel.Name sh.cells(i, 2).Value = rel.Definition sh.cells(i, 3).Value = rel.Note i = i + 1 Next End Sub 'This procedure prints the view definitions and notes to the "Views" sheet Sub PrintViewDefs ( sh As Variant ) Dim i As Integer i = 2 For Each vi In mdl.Views sh.cells(i, 1).Value = vi.Name sh.cells(i, 2).Value = vi.Definition sh.cells(i, 3).Value = vi.Notes i = i + 1 Next End Sub 'This procedure will initialize the workbook with the column headers and the object sheets Sub initWorkBook ( wb As Variant ) Dim ws As Object Set ws = wb.worksheets.Add With ws .Name End With Set ws = wb.worksheets.Add With ws .Name End With Set ws = wb.worksheets.Add With ws .Name End With Set ws = wb.worksheets.Add With ws .Name End With End Sub
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 = "BrowseButton" Then 'browse to excel file if used pushes browse button. Put path in text box. DlgText "WBpath", GetFilePath(,"xls",,"Open SpreadSheet") dialogfunc = True ElseIf DlgItem = "OK" And DlgText("WBpath") = "" And DlgValue("WBchoice") = 1 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