P
Philipp Post
In case it is helpfull to someone: Two years ago here was a post about
creating an Access database from a Visio ER Diagram - thanks to the
original author. I have altered that code to write standard ISO/ANSI
SQL DDL instead.
Comments and additions appreciated.
Thanks n brgds
Philipp Post
+++++++++++++++++++++++++++++++++++++++++++++++++++++
Option Explicit
'--------------------------------------------------------------------------------------------------
'Description: Convert a Visio 2003 Entity Relationship Diagram to SQL
DDL
'Pattern Source:
http://groups.google.com/group/micr...8?lnk=gst&q=forward+engineer#bdc375e8244dfa28
'History
'Date Author Changes
'2008-05-01 JW Initial Version
'2010-04-05 Philipp Post Changed to write ISO/ANSI SQL DDL
instead of an Access Database
'--------------------------------------------------------------------------------------------------
'The goal is to keep the output as much as possible in standard SQL,
so that it will run in
'any SQL RDBMS without too much effort.
'How to install: Put the code into a new module in the *.vsd Visio
drawing and run it from the macros menu.
'Needs a reference to Visio Database Modelling Engine
'Warning: a lot of things, which can be entered in the UI can not be
scripted out, e. g.
'- CHECK constraints
'- DEFAULT values of columns in tables (not possible according to a
web search)
'- notes (not possible according to a web search)
'- VIEWs eVMEKindERView (mixed into entity = table / eVMEKindEREntity)
Public Sub Create_DDL()
'Visio Modelling Engine
Static vme As New VisioModelingEngine
Dim vis_models As IEnumIVMEModels
Dim vis_model As IVMEModel
Dim vis_shapes As IEnumIVMEModelElements
Dim vis_shape As IVMEModelElement
'Tables
Dim vis_table_def As IVMEEntity
Dim vis_table_attribs As IEnumIVMEAttributes
Dim vis_column_def As IVMEAttribute
Dim vis_data_type As IVMEDataType
Dim table_name As String
Dim column_name As String
'Indexes
Dim vis_indexes As IEnumIVMEEntityAnnotations
Dim vis_index As IVMEEntityAnnotation
Dim vis_index_columns As IEnumIVMEAttributes
Dim vis_index_column As IVMEAttribute
'Relationships
Dim vis_relationship As IVMEBinaryRelationship
Dim vis_referenced_columns As IEnumIVMEAttributes
Dim vis_referenced_column As IVMEAttribute
Dim vis_referencing_columns As IEnumIVMEAttributes
Dim vis_referencing_column As IVMEAttribute
Dim constraint_name As String
Dim referencing_table_name As String
Dim referenced_table_name As String
'Output File
Dim file_name As String
Dim response As String
Dim ind_response As String
Dim write_indexes_flag As Boolean
'There is no save as file dialog in Visio VBA (would need access
through API)
file_name = InputBox("Save the DDL file here:", "Save file as", "D:
\Visio_DDL.sql")
'User clicked cancel
If file_name = "" Then Exit Sub
Open file_name For Output As #1
'Print CREATE INDEX statements or not
If MsgBox("Should CREATE INDEX statements be included?", vbYesNo,
"Create DDL") = vbYes Then
write_indexes_flag = True
End If
'Set up refernces to entities ie tables and relationships in the
visio modelling engine
Set vis_models = vme.models
Set vis_model = vis_models.Next
Set vis_shapes = vis_model.elements
Set vis_shape = vis_shapes.Next
'for SQL Server only
response = "-- SQL Server specific settings" & vbCrLf & _
"SET ANSI_NULLS ON " & vbCrLf & _
"GO" & vbCrLf & _
"SET QUOTED_IDENTIFIER ON" & vbCrLf & _
"GO" & vbCrLf & vbCrLf
'On Error GoTo TblErr
response = response & vbCrLf & "--------------------------- TABLES
---------------------------" & vbCrLf & vbCrLf
'Add tables and indexes
Do While Not vis_shape Is Nothing
'Have we got a table definition?
'something is wrong with the VIEW definitions - they are
considered as tables
'although they should be eVMEKindERView
If vis_shape.Type = eVMEKindEREntity Then
'Add Tables
'Set a refernce to the table definition
Set vis_table_def = vis_shape
table_name =
Make_Name_SQL_Compatible(vis_table_def.PhysicalName)
response = response & "CREATE TABLE " & table_name &
vbCrLf & _
"("
'Set a refernce to the columns category of the table
definition
Set vis_table_attribs = vis_table_def.Attributes
'Select first row of column data in the columns category
Set vis_column_def = vis_table_attribs.Next
Do While Not vis_column_def Is Nothing
'Set a reference to the columns datatype
Set vis_data_type = vis_column_def.DataType
'Get the name of the column
column_name =
Make_Name_SQL_Compatible(vis_column_def.PhysicalName)
'Put conceptual column in DDL comments as there is
'no standard, how this is stored in the DB
'http://www.ureader.com/msg/1133174.aspx
'The notes property for ER shapes is not exposed via
the COM interface, so
'you won't be able to get them.
If vis_column_def.ConceptualName <>
vis_column_def.PhysicalName Then
response = response & "-- " &
vis_column_def.ConceptualName & vbCrLf & " "
End If
response = response & column_name
'Portable data types (SQL Standard)
'CHAR
'DECIMAL
'INTEGER
'REAL
'SMALLINT
'VARCHAR
'Proprietary data types
'BINARY
'BIT (in Ansi it is like BINARY in MS Access, no
direct replacement)
'BYTE --> SMALLINT
'COUNTER --> IDENTITY
'CURRENCY --> DECIMAL(15, 4)
'DATETIME --> SQL Standard + DB2 = TIMESTAMP (but NOT
in SQL Server)
'DOUBLE --> FLOAT
'GUID --> CHAR(32)
'LONG --> INTEGER
'LONGBINARY
'LONGCHAR
'LONGTEXT
'NUMERIC --> DECIMAL
'SHORT --> SMALLINT
'SINGLE --> REAL
'TEXT --> NVARCHAR(MAX) in SQL Server,
CLOB(1073741823) in DB2
'VARBINARY
'data type
If vis_data_type.PhysicalName = "BIT" Then
'no direct replacement in SQL Standard (in SQL
Server BIT exists)
'Should be replaced with CHAR(1) NOT NULL
CHECK(<column name> IN('Y', 'N'))
response = response & " CHAR(1)"
ElseIf vis_data_type.PhysicalName = "BYTE" Then
response = response & " SMALLINT"
ElseIf vis_data_type.PhysicalName = "COUNTER" Then
'Identity property (SQL Server, MS Access)
response = response & " IDENTITY(1, 1)"
'IBM DB2
'response = response & " INTEGER " & vbCrLf & _
' " GENERATED BY DEFAULT AS
IDENTITY (START WITH 1, INCREMENT BY 1, CACHE 20)"
ElseIf vis_data_type.PhysicalName = "CURRENCY" Then
'MS Money data type should not be used due to math
problems
response = response & " DECIMAL(15, 4)"
ElseIf vis_data_type.PhysicalName = "DOUBLE" Then
'FLOAT is SQL Standard
response = response & " FLOAT"
ElseIf vis_data_type.PhysicalName = "GUID" Then
'GUID can be replaced
response = response & " CHAR(32)"
ElseIf vis_data_type.PhysicalName = "LONG" Then
response = response & " INTEGER"
ElseIf vis_data_type.PhysicalName = "LONGBINARY" Then
'proprietary SQL Server replacement (old: IMAGE)
response = response & " VARBINARY(MAX)"
ElseIf vis_data_type.PhysicalName = "LONGCHAR" Or _
vis_data_type.PhysicalName = "LONGTEXT" Or _
vis_data_type.PhysicalName = "TEXT" Then
'proprietary SQL Server replacement
'MS Access always uses Unicode for LONGTEXT
response = response & " NVARCHAR(MAX)"
ElseIf vis_data_type.PhysicalName Like "NUMERIC*" Then
'As per MS Access help system NUMERIC should be
converted to DECIMAL
response = response &
Replace(vis_data_type.PhysicalName, "NUMERIC", "DECIMAL")
ElseIf vis_data_type.PhysicalName = "SHORT" Then
response = response & " SMALLINT"
ElseIf vis_data_type.PhysicalName = "SINGLE" Then
'floating point number
response = response & " REAL"
Else
response = response & " " &
vis_data_type.PhysicalName
End If
'Nullability
If vis_column_def.AllowNulls = False Then
response = response & " NOT NULL"
Else
'SQL standard does not require this, but some
rdbms do
'response = response & " NULL"
End If
'DEFAULT values ???
'CHECK constraints ???
'CHECK constraints based on special data types
If vis_data_type.PhysicalName = "BIT" Then
response = response & vbCrLf
response = response & " CHECK(" & column_name & "
IN('Y', 'N'))"
End If
response = response & ", " & vbCrLf & " "
'Select next column in the table definition
Set vis_column_def = vis_table_attribs.Next
Loop
'Add Indexes and Keys
'On Error GoTo IndErr
'Select the indexes in the table definition
Set vis_indexes = vis_table_def.EntityAnnotations
'Select the first Index in the table definition
Set vis_index = vis_indexes.Next
ind_response = ""
Do While Not vis_index Is Nothing
'Create the Index in the database
'VBA does not make a difference between the fact if a
constraint or a key or both
'are concerned as the Visio user interface does
Select Case vis_index.kind
'Primary Key constraint
Case eVMEEREntityAnnotationPrimary
response = response & "CONSTRAINT " &
Make_Name_SQL_Compatible(vis_index.PhysicalName) & " " & vbCrLf & _
" PRIMARY KEY ("
'For SQL server it should be CLUSTERED index,
for DB2 UNIQUE index
ind_response = ind_response & " CREATE UNIQUE
INDEX " & Make_Name_SQL_Compatible(vis_index.PhysicalName & "_IDX") &
" " & vbCrLf & _
" ON " &
table_name & " ("
'Unique constraint
Case eVMEEREntityAnnotationAlternate
response = response & "CONSTRAINT " &
Make_Name_SQL_Compatible(vis_index.PhysicalName) & " " & vbCrLf & _
" UNIQUE ("
'Not unique index
Case eVMEEREntityAnnotationIndex
ind_response = ind_response & " CREATE INDEX "
& Make_Name_SQL_Compatible(vis_index.PhysicalName & "_IDX") & " " &
vbCrLf & _
" ON " &
table_name & " ("
Case eVMEEREntityAnnotationUpperBound
'do nothing - not sure what this is for
End Select
'Select the first column of the Index Definition
Set vis_index_columns = vis_index.Attributes
Set vis_index_column = vis_index_columns.Next
Do While Not vis_index_column Is Nothing
Select Case vis_index.kind
'Primary Key constraint
Case eVMEEREntityAnnotationPrimary
response = response &
Make_Name_SQL_Compatible(vis_index_column.PhysicalName) & ", "
ind_response = ind_response &
Make_Name_SQL_Compatible(vis_index_column.PhysicalName) & ", "
'Unique constraint
Case eVMEEREntityAnnotationAlternate
response = response &
Make_Name_SQL_Compatible(vis_index_column.PhysicalName) & ", "
'Not unique index
Case eVMEEREntityAnnotationIndex
ind_response = ind_response &
Make_Name_SQL_Compatible(vis_index_column.PhysicalName) & ", "
Case eVMEEREntityAnnotationUpperBound
'do nothing - not sure what this is for
End Select
'Select the next column in the index definition
Set vis_index_column = vis_index_columns.Next
Loop
Select Case vis_index.kind
'Primary Key constraint
Case eVMEEREntityAnnotationPrimary
'strip last , of the key column list
response = Left(response, Len(response) - 2)
response = response & "), " & vbCrLf & " "
'strip last , of the index column list
ind_response = Left(ind_response,
Len(ind_response) - 2)
ind_response = ind_response & "); " & vbCrLf &
vbCrLf
'Unique constraint
Case eVMEEREntityAnnotationAlternate
'strip last , of the key column list
response = Left(response, Len(response) - 2)
response = response & "), " & vbCrLf & " "
'Not unique index
Case eVMEEREntityAnnotationIndex
'strip last , of the index column list
ind_response = Left(ind_response,
Len(ind_response) - 2)
ind_response = ind_response & "); " & vbCrLf &
vbCrLf
Case eVMEEREntityAnnotationUpperBound
'do nothing - not sure what this is for
End Select
'Select the next index in the data vis_model
Set vis_index = vis_indexes.Next
Loop
'strip last , of the column/constraint list
'and terminate the CREATE TABLE statement
response = Left(response, Len(response) - 5)
response = response & ");" & vbCrLf & vbCrLf
'add the CREATE INDEX statements right after the table
If write_indexes_flag = True Then
response = response & ind_response
End If
End If
Set vis_shape = vis_shapes.Next
Loop
'End first pass, Set up for the second pass through the vis_model
'On Error GoTo RelErr
Set vis_shapes = vis_model.elements
Set vis_shape = vis_shapes.Next
response = response & vbCrLf & "---------------------------
FOREIGN KEYS ---------------------------" & vbCrLf & vbCrLf
Do While Not vis_shape Is Nothing
'Have we got a relationship?
If vis_shape.Type = eVMEKindERRelationship Then
'Add relationships
Set vis_relationship = vis_shape
'Create Relationship
constraint_name =
Make_Name_SQL_Compatible(vis_relationship.PhysicalName)
'Specify the related / foreign table. (The parent table in
VME)
referencing_table_name =
Make_Name_SQL_Compatible(vis_relationship.FirstEntity.PhysicalName)
'Specify the primary table. (The child table in VME)
referenced_table_name =
Make_Name_SQL_Compatible(vis_relationship.SecondEntity.PhysicalName)
response = response & "ALTER TABLE " &
referencing_table_name & " " & vbCrLf & _
" ADD CONSTRAINT " & constraint_name
& " " & vbCrLf & _
" FOREIGN KEY ("
'Add the columns to the relationship
'Read Foreign table columns
Set vis_referencing_columns =
vis_relationship.FirstAttributes
Set vis_referencing_column = vis_referencing_columns.Next
Do While Not vis_referencing_column Is Nothing
response = response &
Make_Name_SQL_Compatible(vis_referencing_column.PhysicalName) & ", "
'Repeat for other columns if a multi-column relation.
Set vis_referencing_column =
vis_referencing_columns.Next
Loop
'strip last ,
response = Left(response, Len(response) - 2)
response = response & ")" & vbCrLf
'Read Primary table columns
Set vis_referenced_columns =
vis_relationship.SecondAttributes
Set vis_referenced_column = vis_referenced_columns.Next
response = response & " REFERENCES " &
referenced_table_name & " ("
Do While Not vis_referenced_column Is Nothing
response = response &
Make_Name_SQL_Compatible(vis_referenced_column.PhysicalName) & ", "
'Repeat for other columns if a multi-column relation.
Set vis_referenced_column =
vis_referenced_columns.Next
Loop
'strip last ,
response = Left(response, Len(response) - 2)
response = response & ")" & vbCrLf
'define update and delete rules
Select Case vis_relationship.UpdateRule
Case eVMERIRuleCascade
response = response & " ON UPDATE CASCADE" &
vbCrLf
Case eVMERIRuleSetNull
response = response & " ON UPDATE SET NULL" &
vbCrLf
Case eVMERIRuleSetDefault
response = response & " ON UPDATE SET DEFAULT" &
vbCrLf
Case eVMERIRuleNoAction
'ON UPDATE RESTRICT is standard - must not mention
End Select
Select Case vis_relationship.DeleteRule
Case eVMERIRuleCascade
response = response & " ON DELETE CASCADE" &
vbCrLf
Case eVMERIRuleSetNull
response = response & " ON DELETE SET NULL" &
vbCrLf
Case eVMERIRuleSetDefault
response = response & " ON DELETE SET DEFAULT" &
vbCrLf
Case eVMERIRuleNoAction
'ON DELETE RESTRICT is standard - must not mention
End Select
'strip last crlf of the column list
response = Left(response, Len(response) - 2)
response = response & ";" & vbCrLf & vbCrLf
End If
Set vis_shape = vis_shapes.Next
Loop
'Write the resulte to file and close it
Print #1, response
Close (1)
Exit Sub
TblErr:
Debug.Print "Tbl Err"
Debug.Print " "
Resume Next
IndErr:
Debug.Print vis_table_def.PhysicalName, vis_index.PhysicalName,
Err.Description, "Idx Err"
Debug.Print " "
Resume Next
RelErr:
Debug.Print vis_relationship.SecondEntity.PhysicalName,
vis_relationship.FirstEntity.PhysicalName, Err.Description, "Rel Err"
Debug.Print " "
Resume Next
End Sub
'Description: Handle white spaces in object names
'Author: PP 2010-04-06
Private Function Make_Name_SQL_Compatible(ByVal object_name As String)
As String
If InStr(1, object_name, " ") > 0 Then
'for table names with spaces in it
'as per ANSI, use double quotes
'SQL Server uses [], but can be set to double quotes - SET
QUOTED_IDENTIFIER ON
object_name = """" & object_name & """"
End If
Make_Name_SQL_Compatible = object_name
End Function
creating an Access database from a Visio ER Diagram - thanks to the
original author. I have altered that code to write standard ISO/ANSI
SQL DDL instead.
Comments and additions appreciated.
Thanks n brgds
Philipp Post
+++++++++++++++++++++++++++++++++++++++++++++++++++++
Option Explicit
'--------------------------------------------------------------------------------------------------
'Description: Convert a Visio 2003 Entity Relationship Diagram to SQL
DDL
'Pattern Source:
http://groups.google.com/group/micr...8?lnk=gst&q=forward+engineer#bdc375e8244dfa28
'History
'Date Author Changes
'2008-05-01 JW Initial Version
'2010-04-05 Philipp Post Changed to write ISO/ANSI SQL DDL
instead of an Access Database
'--------------------------------------------------------------------------------------------------
'The goal is to keep the output as much as possible in standard SQL,
so that it will run in
'any SQL RDBMS without too much effort.
'How to install: Put the code into a new module in the *.vsd Visio
drawing and run it from the macros menu.
'Needs a reference to Visio Database Modelling Engine
'Warning: a lot of things, which can be entered in the UI can not be
scripted out, e. g.
'- CHECK constraints
'- DEFAULT values of columns in tables (not possible according to a
web search)
'- notes (not possible according to a web search)
'- VIEWs eVMEKindERView (mixed into entity = table / eVMEKindEREntity)
Public Sub Create_DDL()
'Visio Modelling Engine
Static vme As New VisioModelingEngine
Dim vis_models As IEnumIVMEModels
Dim vis_model As IVMEModel
Dim vis_shapes As IEnumIVMEModelElements
Dim vis_shape As IVMEModelElement
'Tables
Dim vis_table_def As IVMEEntity
Dim vis_table_attribs As IEnumIVMEAttributes
Dim vis_column_def As IVMEAttribute
Dim vis_data_type As IVMEDataType
Dim table_name As String
Dim column_name As String
'Indexes
Dim vis_indexes As IEnumIVMEEntityAnnotations
Dim vis_index As IVMEEntityAnnotation
Dim vis_index_columns As IEnumIVMEAttributes
Dim vis_index_column As IVMEAttribute
'Relationships
Dim vis_relationship As IVMEBinaryRelationship
Dim vis_referenced_columns As IEnumIVMEAttributes
Dim vis_referenced_column As IVMEAttribute
Dim vis_referencing_columns As IEnumIVMEAttributes
Dim vis_referencing_column As IVMEAttribute
Dim constraint_name As String
Dim referencing_table_name As String
Dim referenced_table_name As String
'Output File
Dim file_name As String
Dim response As String
Dim ind_response As String
Dim write_indexes_flag As Boolean
'There is no save as file dialog in Visio VBA (would need access
through API)
file_name = InputBox("Save the DDL file here:", "Save file as", "D:
\Visio_DDL.sql")
'User clicked cancel
If file_name = "" Then Exit Sub
Open file_name For Output As #1
'Print CREATE INDEX statements or not
If MsgBox("Should CREATE INDEX statements be included?", vbYesNo,
"Create DDL") = vbYes Then
write_indexes_flag = True
End If
'Set up refernces to entities ie tables and relationships in the
visio modelling engine
Set vis_models = vme.models
Set vis_model = vis_models.Next
Set vis_shapes = vis_model.elements
Set vis_shape = vis_shapes.Next
'for SQL Server only
response = "-- SQL Server specific settings" & vbCrLf & _
"SET ANSI_NULLS ON " & vbCrLf & _
"GO" & vbCrLf & _
"SET QUOTED_IDENTIFIER ON" & vbCrLf & _
"GO" & vbCrLf & vbCrLf
'On Error GoTo TblErr
response = response & vbCrLf & "--------------------------- TABLES
---------------------------" & vbCrLf & vbCrLf
'Add tables and indexes
Do While Not vis_shape Is Nothing
'Have we got a table definition?
'something is wrong with the VIEW definitions - they are
considered as tables
'although they should be eVMEKindERView
If vis_shape.Type = eVMEKindEREntity Then
'Add Tables
'Set a refernce to the table definition
Set vis_table_def = vis_shape
table_name =
Make_Name_SQL_Compatible(vis_table_def.PhysicalName)
response = response & "CREATE TABLE " & table_name &
vbCrLf & _
"("
'Set a refernce to the columns category of the table
definition
Set vis_table_attribs = vis_table_def.Attributes
'Select first row of column data in the columns category
Set vis_column_def = vis_table_attribs.Next
Do While Not vis_column_def Is Nothing
'Set a reference to the columns datatype
Set vis_data_type = vis_column_def.DataType
'Get the name of the column
column_name =
Make_Name_SQL_Compatible(vis_column_def.PhysicalName)
'Put conceptual column in DDL comments as there is
'no standard, how this is stored in the DB
'http://www.ureader.com/msg/1133174.aspx
'The notes property for ER shapes is not exposed via
the COM interface, so
'you won't be able to get them.
If vis_column_def.ConceptualName <>
vis_column_def.PhysicalName Then
response = response & "-- " &
vis_column_def.ConceptualName & vbCrLf & " "
End If
response = response & column_name
'Portable data types (SQL Standard)
'CHAR
'DECIMAL
'INTEGER
'REAL
'SMALLINT
'VARCHAR
'Proprietary data types
'BINARY
'BIT (in Ansi it is like BINARY in MS Access, no
direct replacement)
'BYTE --> SMALLINT
'COUNTER --> IDENTITY
'CURRENCY --> DECIMAL(15, 4)
'DATETIME --> SQL Standard + DB2 = TIMESTAMP (but NOT
in SQL Server)
'DOUBLE --> FLOAT
'GUID --> CHAR(32)
'LONG --> INTEGER
'LONGBINARY
'LONGCHAR
'LONGTEXT
'NUMERIC --> DECIMAL
'SHORT --> SMALLINT
'SINGLE --> REAL
'TEXT --> NVARCHAR(MAX) in SQL Server,
CLOB(1073741823) in DB2
'VARBINARY
'data type
If vis_data_type.PhysicalName = "BIT" Then
'no direct replacement in SQL Standard (in SQL
Server BIT exists)
'Should be replaced with CHAR(1) NOT NULL
CHECK(<column name> IN('Y', 'N'))
response = response & " CHAR(1)"
ElseIf vis_data_type.PhysicalName = "BYTE" Then
response = response & " SMALLINT"
ElseIf vis_data_type.PhysicalName = "COUNTER" Then
'Identity property (SQL Server, MS Access)
response = response & " IDENTITY(1, 1)"
'IBM DB2
'response = response & " INTEGER " & vbCrLf & _
' " GENERATED BY DEFAULT AS
IDENTITY (START WITH 1, INCREMENT BY 1, CACHE 20)"
ElseIf vis_data_type.PhysicalName = "CURRENCY" Then
'MS Money data type should not be used due to math
problems
response = response & " DECIMAL(15, 4)"
ElseIf vis_data_type.PhysicalName = "DOUBLE" Then
'FLOAT is SQL Standard
response = response & " FLOAT"
ElseIf vis_data_type.PhysicalName = "GUID" Then
'GUID can be replaced
response = response & " CHAR(32)"
ElseIf vis_data_type.PhysicalName = "LONG" Then
response = response & " INTEGER"
ElseIf vis_data_type.PhysicalName = "LONGBINARY" Then
'proprietary SQL Server replacement (old: IMAGE)
response = response & " VARBINARY(MAX)"
ElseIf vis_data_type.PhysicalName = "LONGCHAR" Or _
vis_data_type.PhysicalName = "LONGTEXT" Or _
vis_data_type.PhysicalName = "TEXT" Then
'proprietary SQL Server replacement
'MS Access always uses Unicode for LONGTEXT
response = response & " NVARCHAR(MAX)"
ElseIf vis_data_type.PhysicalName Like "NUMERIC*" Then
'As per MS Access help system NUMERIC should be
converted to DECIMAL
response = response &
Replace(vis_data_type.PhysicalName, "NUMERIC", "DECIMAL")
ElseIf vis_data_type.PhysicalName = "SHORT" Then
response = response & " SMALLINT"
ElseIf vis_data_type.PhysicalName = "SINGLE" Then
'floating point number
response = response & " REAL"
Else
response = response & " " &
vis_data_type.PhysicalName
End If
'Nullability
If vis_column_def.AllowNulls = False Then
response = response & " NOT NULL"
Else
'SQL standard does not require this, but some
rdbms do
'response = response & " NULL"
End If
'DEFAULT values ???
'CHECK constraints ???
'CHECK constraints based on special data types
If vis_data_type.PhysicalName = "BIT" Then
response = response & vbCrLf
response = response & " CHECK(" & column_name & "
IN('Y', 'N'))"
End If
response = response & ", " & vbCrLf & " "
'Select next column in the table definition
Set vis_column_def = vis_table_attribs.Next
Loop
'Add Indexes and Keys
'On Error GoTo IndErr
'Select the indexes in the table definition
Set vis_indexes = vis_table_def.EntityAnnotations
'Select the first Index in the table definition
Set vis_index = vis_indexes.Next
ind_response = ""
Do While Not vis_index Is Nothing
'Create the Index in the database
'VBA does not make a difference between the fact if a
constraint or a key or both
'are concerned as the Visio user interface does
Select Case vis_index.kind
'Primary Key constraint
Case eVMEEREntityAnnotationPrimary
response = response & "CONSTRAINT " &
Make_Name_SQL_Compatible(vis_index.PhysicalName) & " " & vbCrLf & _
" PRIMARY KEY ("
'For SQL server it should be CLUSTERED index,
for DB2 UNIQUE index
ind_response = ind_response & " CREATE UNIQUE
INDEX " & Make_Name_SQL_Compatible(vis_index.PhysicalName & "_IDX") &
" " & vbCrLf & _
" ON " &
table_name & " ("
'Unique constraint
Case eVMEEREntityAnnotationAlternate
response = response & "CONSTRAINT " &
Make_Name_SQL_Compatible(vis_index.PhysicalName) & " " & vbCrLf & _
" UNIQUE ("
'Not unique index
Case eVMEEREntityAnnotationIndex
ind_response = ind_response & " CREATE INDEX "
& Make_Name_SQL_Compatible(vis_index.PhysicalName & "_IDX") & " " &
vbCrLf & _
" ON " &
table_name & " ("
Case eVMEEREntityAnnotationUpperBound
'do nothing - not sure what this is for
End Select
'Select the first column of the Index Definition
Set vis_index_columns = vis_index.Attributes
Set vis_index_column = vis_index_columns.Next
Do While Not vis_index_column Is Nothing
Select Case vis_index.kind
'Primary Key constraint
Case eVMEEREntityAnnotationPrimary
response = response &
Make_Name_SQL_Compatible(vis_index_column.PhysicalName) & ", "
ind_response = ind_response &
Make_Name_SQL_Compatible(vis_index_column.PhysicalName) & ", "
'Unique constraint
Case eVMEEREntityAnnotationAlternate
response = response &
Make_Name_SQL_Compatible(vis_index_column.PhysicalName) & ", "
'Not unique index
Case eVMEEREntityAnnotationIndex
ind_response = ind_response &
Make_Name_SQL_Compatible(vis_index_column.PhysicalName) & ", "
Case eVMEEREntityAnnotationUpperBound
'do nothing - not sure what this is for
End Select
'Select the next column in the index definition
Set vis_index_column = vis_index_columns.Next
Loop
Select Case vis_index.kind
'Primary Key constraint
Case eVMEEREntityAnnotationPrimary
'strip last , of the key column list
response = Left(response, Len(response) - 2)
response = response & "), " & vbCrLf & " "
'strip last , of the index column list
ind_response = Left(ind_response,
Len(ind_response) - 2)
ind_response = ind_response & "); " & vbCrLf &
vbCrLf
'Unique constraint
Case eVMEEREntityAnnotationAlternate
'strip last , of the key column list
response = Left(response, Len(response) - 2)
response = response & "), " & vbCrLf & " "
'Not unique index
Case eVMEEREntityAnnotationIndex
'strip last , of the index column list
ind_response = Left(ind_response,
Len(ind_response) - 2)
ind_response = ind_response & "); " & vbCrLf &
vbCrLf
Case eVMEEREntityAnnotationUpperBound
'do nothing - not sure what this is for
End Select
'Select the next index in the data vis_model
Set vis_index = vis_indexes.Next
Loop
'strip last , of the column/constraint list
'and terminate the CREATE TABLE statement
response = Left(response, Len(response) - 5)
response = response & ");" & vbCrLf & vbCrLf
'add the CREATE INDEX statements right after the table
If write_indexes_flag = True Then
response = response & ind_response
End If
End If
Set vis_shape = vis_shapes.Next
Loop
'End first pass, Set up for the second pass through the vis_model
'On Error GoTo RelErr
Set vis_shapes = vis_model.elements
Set vis_shape = vis_shapes.Next
response = response & vbCrLf & "---------------------------
FOREIGN KEYS ---------------------------" & vbCrLf & vbCrLf
Do While Not vis_shape Is Nothing
'Have we got a relationship?
If vis_shape.Type = eVMEKindERRelationship Then
'Add relationships
Set vis_relationship = vis_shape
'Create Relationship
constraint_name =
Make_Name_SQL_Compatible(vis_relationship.PhysicalName)
'Specify the related / foreign table. (The parent table in
VME)
referencing_table_name =
Make_Name_SQL_Compatible(vis_relationship.FirstEntity.PhysicalName)
'Specify the primary table. (The child table in VME)
referenced_table_name =
Make_Name_SQL_Compatible(vis_relationship.SecondEntity.PhysicalName)
response = response & "ALTER TABLE " &
referencing_table_name & " " & vbCrLf & _
" ADD CONSTRAINT " & constraint_name
& " " & vbCrLf & _
" FOREIGN KEY ("
'Add the columns to the relationship
'Read Foreign table columns
Set vis_referencing_columns =
vis_relationship.FirstAttributes
Set vis_referencing_column = vis_referencing_columns.Next
Do While Not vis_referencing_column Is Nothing
response = response &
Make_Name_SQL_Compatible(vis_referencing_column.PhysicalName) & ", "
'Repeat for other columns if a multi-column relation.
Set vis_referencing_column =
vis_referencing_columns.Next
Loop
'strip last ,
response = Left(response, Len(response) - 2)
response = response & ")" & vbCrLf
'Read Primary table columns
Set vis_referenced_columns =
vis_relationship.SecondAttributes
Set vis_referenced_column = vis_referenced_columns.Next
response = response & " REFERENCES " &
referenced_table_name & " ("
Do While Not vis_referenced_column Is Nothing
response = response &
Make_Name_SQL_Compatible(vis_referenced_column.PhysicalName) & ", "
'Repeat for other columns if a multi-column relation.
Set vis_referenced_column =
vis_referenced_columns.Next
Loop
'strip last ,
response = Left(response, Len(response) - 2)
response = response & ")" & vbCrLf
'define update and delete rules
Select Case vis_relationship.UpdateRule
Case eVMERIRuleCascade
response = response & " ON UPDATE CASCADE" &
vbCrLf
Case eVMERIRuleSetNull
response = response & " ON UPDATE SET NULL" &
vbCrLf
Case eVMERIRuleSetDefault
response = response & " ON UPDATE SET DEFAULT" &
vbCrLf
Case eVMERIRuleNoAction
'ON UPDATE RESTRICT is standard - must not mention
End Select
Select Case vis_relationship.DeleteRule
Case eVMERIRuleCascade
response = response & " ON DELETE CASCADE" &
vbCrLf
Case eVMERIRuleSetNull
response = response & " ON DELETE SET NULL" &
vbCrLf
Case eVMERIRuleSetDefault
response = response & " ON DELETE SET DEFAULT" &
vbCrLf
Case eVMERIRuleNoAction
'ON DELETE RESTRICT is standard - must not mention
End Select
'strip last crlf of the column list
response = Left(response, Len(response) - 2)
response = response & ";" & vbCrLf & vbCrLf
End If
Set vis_shape = vis_shapes.Next
Loop
'Write the resulte to file and close it
Print #1, response
Close (1)
Exit Sub
TblErr:
Debug.Print "Tbl Err"
Debug.Print " "
Resume Next
IndErr:
Debug.Print vis_table_def.PhysicalName, vis_index.PhysicalName,
Err.Description, "Idx Err"
Debug.Print " "
Resume Next
RelErr:
Debug.Print vis_relationship.SecondEntity.PhysicalName,
vis_relationship.FirstEntity.PhysicalName, Err.Description, "Rel Err"
Debug.Print " "
Resume Next
End Sub
'Description: Handle white spaces in object names
'Author: PP 2010-04-06
Private Function Make_Name_SQL_Compatible(ByVal object_name As String)
As String
If InStr(1, object_name, " ") > 0 Then
'for table names with spaces in it
'as per ANSI, use double quotes
'SQL Server uses [], but can be set to double quotes - SET
QUOTED_IDENTIFIER ON
object_name = """" & object_name & """"
End If
Make_Name_SQL_Compatible = object_name
End Function