Export Metadata to Excel Version 3

      'TITLE:  Export Metadata to Excel Version 3
      'DESCRIPTION: This macro outputs model meta data to Excel in
      'a format which may be appealing for a finished report.
      'NOTES:
      '   Information will be exported for each entity/table that is
      '	selected prior to executing the macro.
      'DATE:  3/4/2002
      'AUTHOR:  Jason Tiret
      'CONTACT:  http://support.embarcadero.com/
      
      
      '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 excel variables
      Dim wb As Object
      Dim sheet As Object
      Dim excel As Object
      Dim selectedrange As Object
      
      
      
      Sub Main
      
      	Set diag = DiagramManager.ActiveDiagram
      	Set mdl = diag.ActiveModel
      	Set submdl = mdl.ActiveSubModel
      
      	Set excel = CreateObject("excel.application")
      	excel.visible = True
      
      	Dim curRow As Integer
      
      
      	PrintHeader
      	curRow = 3
      
      	If submdl.SelectedObjects.Count > 0 Then
      
      	For Each so In submdl.SelectedObjects
      
      		If so.Type = 1 Then
      
      			Set ent = mdl.Entities.Item(so.ID)
      
      			For Each attr In ent.Attributes
      
      				sheet.cells(curRow,1).Value = ent.EntityName
      				
      				If attr.HasLogicalRoleName = True Then
      					sheet.cells(curRow,2).Value = attr.LogicalRoleName
      				Else
      					sheet.cells(curRow,2).Value = attr.AttributeName
      				End If
      
      				sheet.cells(curRow,3).Value = attr.Definition
      				sheet.cells(curRow,4).Value = attr.ColumnName
      
      				Dim Datastring As String
      
      				Datastring = attr.CompositeDatatype
      				Datastring = Replace(Datastring, " NOT", "")
      				Datastring = Replace(Datastring, " NULL", "")
      
      				If InStr(Datastring, "(") <> 0 Then
      					Datastring = Left(Datastring,InStr(Datastring, "(") - 1)
      				End If
      
      				sheet.cells(curRow,5).Value = Datastring
      
      				If attr.DataLength > 0 Then
      					sheet.cells(curRow,6).Value = attr.DataLength
      				End If
      
      				If attr.DataScale > 0 Then
      					sheet.cells(curRow,7).Value = attr.DataScale
      				End If
      
      				If NullOption(attr) = "N" Then
      					sheet.cells(curRow,9).Value = "OPTIONAL"
      				Else
      					sheet.cells(curRow,9).Value = "MANDATORY"
      				End If
      
      				sheet.cells(curRow,10).Value = NullOption(attr)
      				sheet.cells(curRow,11).Value = KeyOption(attr)
      
      				curRow = curRow + 1
      
      			Next
      
      		End If
      
      	Next
      
      	End If
      
      	
      End Sub
      
      Function KeyOption ( att As AttributeObj ) As String
      
      	Dim keystr As String
      
      	If att.PrimaryKey = True Then
      
      		keystr = "(PK)"
      
      	End If
      
      	If att.ForeignKey = True Then
      
      		keystr = keystr & "(FK)"
      
      	End If
      
      	KeyOption = keystr
      
      End Function
      
      Function NullOption ( att As AttributeObj ) As String
      
      	Dim nullstr As String
      
      	If UCase(att.NullOption) = "NULL" Then
      
      		nullstr = "N"
      
      	End If
      
      	If UCase(att.NullOption) = "NOT NULL" Then
      
      		nullstr = "NN"
      
      	End If
      
      	If UCase(att.NullOption) = "NOT NULL" And att.DeclaredDefault <> "" Then
      
      		nullstr = "ND"
      
      	End If
      
      	NullOption = nullstr
      
      End Function
      
      
      Function Datatype ( DT As String ) As String
      	
      	Dim test As String
      
      	test = UCase(DT)
      
      	Select Case test
      
      		Case "DATE"
      			Datatype = "D"
      
      		Case "TIMESTAMP/DATE","TIMESTAMP","DATETIME","DATETIMN","SMALLDATETIME","TIME/DATETIME"
      			Datatype = "T"
      
      		Case "VARCHAR","VARCHAR2","NVARCHAR","CHAR","LONG VARCHAR","NTEXT/LONG VARCHAR","NCHAR","MLSLABEL/VARCHAR","ROWID/VARCHAR","BIT","BOOL","BOOLEAN","TEXT","IMAGE/LONG BINARY","IMAGE","BINARY","VARBINARY/BLOB","BLOB","CLOB"
      			Datatype = "C"
      
      		Case "ID","NUMERIC","NUMBER","DECIMAL","MONEY","SMALLMONEY","MONEYN","DECIMALN","PICTURE","FLOAT","SINGLE","REAL/SMALLFLOAT","FLOATN","NUMBER","DOUBLE","DOUBLE PRECISION","INTEGER","INT","INTN","SERIAL/INTEGER","COUNTER","UNIQUEID","SMALLINT","TINYINT"
      			Datatype = "N"
      
      		Case Else
      			datatyp = "C"
      	End Select
      
      End Function
      
      
      
      
      Sub PrintHeader
      
      	Set wb = excel.workbooks.Add
      	Set sheet = wb.activesheet
      
      
      	sheet.cells(1,1).Value = "=NOW()"
      	sheet.cells(1,1).font.colorindex = 3
      
      	With sheet.range("A:L")
      			.wraptext = True
      			.cells.borders.colorindex = 1
      			.font.Name = "ZapfHumnst BT"
      	End With
      
      
      	With sheet.range("A2:L2")
      		.interior.colorindex = 15
      		.font.Bold = True
      		.font.Size = 9
      	End With
      
      
      	With sheet.range("E:G")
      		.horizontalalignment = -4108
      	End With
      
      	sheet.Columns(10).horizontalalignment = -4108
      
      	sheet.Columns(1).columnwidth = 16.29
      	sheet.Columns(2).columnwidth = 17.86
      	sheet.Columns(3).columnwidth = 52.14
      	sheet.Columns(4).columnwidth = 22.14
      	sheet.Columns(5).columnwidth = 14
      	sheet.Columns(6).columnwidth = 10.29
      	sheet.Columns(7).columnwidth = 10.71
      	sheet.Columns(8).columnwidth = 23.43
      	sheet.Columns(9).columnwidth = 13
      	sheet.Columns(10).columnwidth = 11.71
      	sheet.Columns(11).columnwidth = 11.57
      	sheet.Columns(12).columnwidth = 23.29
      
      	sheet.cells(2,1).Value = "TABLE BUSINESS NAME"
      	sheet.cells(2,2).Value = "COLUMN BUSINESS NAME"
      	sheet.cells(2,3).Value = "COLUMN BUSINESS DEFINITION"
      	sheet.cells(2,4).Value = "COLUMN TECHNICAL NAME"
      	sheet.cells(2,5).Value = "COLUMN DATA TYPE"
      	sheet.cells(2,6).Value = "TOTAL COLUMN LENGTH"
      	sheet.cells(2,7).Value = "# OF PLACES TO RIGHT OF DECIMAL"
      	sheet.cells(2,8).Value = "VALID VALUES"
      	sheet.cells(2,9).Value = "MANDATORY/ OPTIONAL         (Is Value Required)"
      	sheet.cells(2,10).Value = "N=NULL NN=Not Null ND=Not Null W/Default"
      	sheet.cells(2,11).Value = "Primary Key (PK)           Foreign Key (FK)"
      	sheet.cells(2,12).Value = "Comments or Source Positions"
      
      	sheet.cells(3,12).Value = ""
      
      	With sheet.range("A2:L2")
      		.verticalalignment = -4160
      		.horizontalalignment = -4108
      	End With
      
      	sheet.Columns(11).horizontalalignment = 1
      
      	For i = 1 To 11
      
      		sheet.cells(1,i).borders(10).colorindex = -4142
      
      	Next
      
      
      
      End Sub