Forward Engineer Visio ER Diagram to MS Access Database

After trawling through google searching for some vba code to convert a Visio
2003 Entity Relationship Diagram to a Microsoft Access 2003 Database and
coming up with nothing, I had to generate all the code myself.

The code is fairly idiot proof, hope someone find it useful.


Option Explicit

Const newDBPath As String = "C:\newDB.mdb"

Public Sub New_Db1()

Dim db As DAO.Database

'Visio Modelling Engine
Static vme As New VisioModelingEngine
Dim models As IEnumIVMEModels
Dim model As IVMEModel
Dim elements As IEnumIVMEModelElements
Dim dwgObj As IVMEModelElement

'Tables
Dim objTblDef As IVMEEntity
Dim objTblAttribs As IEnumIVMEAttributes
Dim objFldDef As IVMEAttribute
Dim objDataType As IVMEDataType
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim strName As String

'Indexes
Dim objIndexes As IEnumIVMEEntityAnnotations
Dim objIndex As IVMEEntityAnnotation
Dim objIndexFlds As IEnumIVMEAttributes
Dim objIndexFld As IVMEAttribute
Dim ind As DAO.Index

'Relationships
Dim objRltshp As IVMEBinaryRelationship
Dim objIndexPriFlds As IEnumIVMEAttributes
Dim objIndexPriFld As IVMEAttribute
Dim objIndexFrgFlds As IEnumIVMEAttributes
Dim objIndexFrgFld As IVMEAttribute
Dim rel As DAO.Relation

'Delete existing Database
On Error Resume Next
Kill newDBPath
On Error GoTo 0

'Create new DAO database
Set db = CreateDatabase(newDBPath, dbLangGeneral)

'Set up refernces to entities ie tables and relationships in the visio
modelling engine
Set models = vme.models
Set model = models.Next
Set elements = model.elements
Set dwgObj = elements.Next

On Error GoTo TblErr

'Add tables and indexes
Do While Not dwgObj Is Nothing

'Have we got a table definition?
If dwgObj.Type = eVMEKindEREntity Then

'Add Tables

'Set a refernce to the table definition
Set objTblDef = dwgObj

'Create DAO Table Def
Set tdf = db.CreateTableDef(objTblDef.PhysicalName)

'Set a refernce to the columns category of the table definition
Set objTblAttribs = objTblDef.Attributes

'Select first row of field data in the columns category
Set objFldDef = objTblAttribs.Next

Do While Not objFldDef Is Nothing

'Set a reference to the fields datatype
Set objDataType = objFldDef.DataType

'Get the name of the field
strName = objFldDef.PhysicalName

'Get the name of the fields datatype
Select Case Left(UCase(objDataType.PhysicalName), 5)

Case "TEXT(", "CHAR(", "VARCH"
Dim length As Integer
length = Mid(objDataType.PhysicalName,
InStr(objDataType.PhysicalName, "(") + 1, (Len(objDataType.PhysicalName) -
InStr(objDataType.PhysicalName, "(") - 1))
If length 255 Then
Set fld = tdf.CreateField(strName, dbMemo)
Else
Set fld = tdf.CreateField(strName, dbText, length)
End If

Case "COUNT" 'Autonumber fields
Set fld = tdf.CreateField(strName, dbLong)
fld.Attributes = dbAutoIncrField

'Create DAO fields as required
Case "LONG": Set fld = tdf.CreateField(strName, dbLong)
Case "DOUBL", "DECIM", "NUMER": Set fld =
tdf.CreateField(strName, dbDouble)
Case "INTEG", "SMALL", "SHORT": Set fld =
tdf.CreateField(strName, dbInteger)
Case "SINGL", "REAL": Set fld = tdf.CreateField(strName,
dbSingle)
Case "DATET": Set fld = tdf.CreateField(strName, dbDate)
Case "BIT": Set fld = tdf.CreateField(strName, dbBoolean)
Case "BYTE": Set fld = tdf.CreateField(strName, dbByte)
Case "CURRE": Set fld = tdf.CreateField(strName,
dbCurrency)
Case "FLOAT": Set fld = tdf.CreateField(strName, dbFloat)
Case "GUID": Set fld = tdf.CreateField(strName, dbGUID)
Case "LONGB": Set fld = tdf.CreateField(strName,
dbLongBinary)
Case "LONGT", "LONGC": Set fld =
tdf.CreateField(strName, dbMemo)
Case "BINAR", "VARBI"
length = Mid(objDataType.PhysicalName,
InStr(objDataType.PhysicalName, "(") + 1, (Len(objDataType.PhysicalName) -
InStr(objDataType.PhysicalName, "(") - 1))
Set fld = tdf.CreateField(strName, dbBinary, length)
Case Else: length = 1 / 0 'Stop code to enable debug

End Select

'Set field attributes
If objFldDef.AllowNulls = False Then
fld.Required = True
End If

'Save field in DAO table def
tdf.Fields.Append fld

'Select next field in the table definition
Set objFldDef = objTblAttribs.Next

Loop

'Save the new table.
db.TableDefs.Append tdf

'Add Indexes

On Error GoTo IndErr

'Select the indexes in the table definition
Set objIndexes = objTblDef.EntityAnnotations

'Select the first Index in the table definition
Set objIndex = objIndexes.Next

Do While Not objIndex Is Nothing

'Create the Index in the database
Set ind = tdf.CreateIndex(objIndex.PhysicalName)

'Select the first field of the Index Definition
Set objIndexFlds = objIndex.Attributes
Set objIndexFld = objIndexFlds.Next

Do While Not objIndexFld Is Nothing

'Add field to index in database
ind.Fields.Append
ind.CreateField(objIndexFld.PhysicalName)

'Select the next field in the index definition
Set objIndexFld = objIndexFlds.Next

Loop

'Primary Index
If objIndex.kind = eVMEEREntityAnnotationPrimary Then
ind.Primary = True
End If

'Unique Index
If objIndex.kind = eVMEEREntityAnnotationAlternate Then
ind.Unique = True
End If

'Add index to database
tdf.Indexes.Append ind

'Select the next index in the data model
Set objIndex = objIndexes.Next

Loop

End If

Set dwgObj = elements.Next

Loop

'End first pass, Set up for the second pass through the model
On Error GoTo RelErr

Set elements = model.elements
Set dwgObj = elements.Next

Do While Not dwgObj Is Nothing

'Have we got a relationship?
If dwgObj.Type = eVMEKindERRelationship Then

'Add relationships

Set objRltshp = dwgObj

'Create Relationship
Set rel = db.CreateRelation(objRltshp.PhysicalName)

'Define its properties.
With rel

'Specify the primary table. (The child table in VME)
.Table = objRltshp.SecondEntity.PhysicalName

'Specify the related / foreign table. (The parent table in
VME)
.ForeignTable = objRltshp.FirstEntity.PhysicalName

'Specify attributes for cascading updates and deletes.
If objRltshp.UpdateRule = eVMERIRuleCascade Then
.Attributes = dbRelationUpdateCascade
End If

If objRltshp.DeleteRule = eVMERIRuleCascade Then
.Attributes = dbRelationDeleteCascade
End If

'Add the fields to the relationship

'Read Primary table fields
Set objIndexPriFlds = objRltshp.SecondAttributes
Set objIndexPriFld = objIndexPriFlds.Next

'Read Foreign table fields
Set objIndexFrgFlds = objRltshp.FirstAttributes
Set objIndexFrgFld = objIndexFrgFlds.Next

Do While Not objIndexPriFld Is Nothing

'Field name in primary table.
Set fld = .CreateField(objIndexPriFld.PhysicalName)

'Field name in related table.
fld.ForeignName = objIndexFrgFld.PhysicalName

'Append the fields to the relationship
.Fields.Append fld

'Repeat for other fields if a multi-field relation.
Set objIndexPriFld = objIndexPriFlds.Next
Set objIndexFrgFld = objIndexFrgFlds.Next

Loop

End With

'Save the newly defined relation to the Relations collection.
db.Relations.Append rel

End If

Set dwgObj = elements.Next

Loop

Set db = Nothing

Exit Sub

TblErr:
Debug.Print "Tbl Err"
Debug.Print " "
Resume Next

IndErr:
Debug.Print objTblDef.PhysicalName, objIndex.PhysicalName,
Err.Description, "Idx Err"
Debug.Print " "
Resume Next

RelErr:
Debug.Print objRltshp.SecondEntity.PhysicalName,
objRltshp.FirstEntity.PhysicalName, Err.Description, "Rel Err"
Debug.Print " "
Resume Next

End Sub

Nicely done. I'm sure there are a lot of users out there that will want to
take advantage of it.
al

"JW" wrote in message
...
After trawling through google searching for some vba code to convert a
Visio
2003 Entity Relationship Diagram to a Microsoft Access 2003 Database and
coming up with nothing, I had to generate all the code myself.

The code is fairly idiot proof, hope someone find it useful.


Option Explicit

Const newDBPath As String = "C:\newDB.mdb"

Public Sub New_Db1()

Dim db As DAO.Database

'Visio Modelling Engine
Static vme As New VisioModelingEngine
Dim models As IEnumIVMEModels
Dim model As IVMEModel
Dim elements As IEnumIVMEModelElements
Dim dwgObj As IVMEModelElement

'Tables
Dim objTblDef As IVMEEntity
Dim objTblAttribs As IEnumIVMEAttributes
Dim objFldDef As IVMEAttribute
Dim objDataType As IVMEDataType
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim strName As String

'Indexes
Dim objIndexes As IEnumIVMEEntityAnnotations
Dim objIndex As IVMEEntityAnnotation
Dim objIndexFlds As IEnumIVMEAttributes
Dim objIndexFld As IVMEAttribute
Dim ind As DAO.Index

'Relationships
Dim objRltshp As IVMEBinaryRelationship
Dim objIndexPriFlds As IEnumIVMEAttributes
Dim objIndexPriFld As IVMEAttribute
Dim objIndexFrgFlds As IEnumIVMEAttributes
Dim objIndexFrgFld As IVMEAttribute
Dim rel As DAO.Relation

'Delete existing Database
On Error Resume Next
Kill newDBPath
On Error GoTo 0

'Create new DAO database
Set db = CreateDatabase(newDBPath, dbLangGeneral)

'Set up refernces to entities ie tables and relationships in the visio
modelling engine
Set models = vme.models
Set model = models.Next
Set elements = model.elements
Set dwgObj = elements.Next

On Error GoTo TblErr

'Add tables and indexes
Do While Not dwgObj Is Nothing

'Have we got a table definition?
If dwgObj.Type = eVMEKindEREntity Then

'Add Tables

'Set a refernce to the table definition
Set objTblDef = dwgObj

'Create DAO Table Def
Set tdf = db.CreateTableDef(objTblDef.PhysicalName)

'Set a refernce to the columns category of the table definition
Set objTblAttribs = objTblDef.Attributes

'Select first row of field data in the columns category
Set objFldDef = objTblAttribs.Next

Do While Not objFldDef Is Nothing

'Set a reference to the fields datatype
Set objDataType = objFldDef.DataType

'Get the name of the field
strName = objFldDef.PhysicalName

'Get the name of the fields datatype
Select Case Left(UCase(objDataType.PhysicalName), 5)

Case "TEXT(", "CHAR(", "VARCH"
Dim length As Integer
length = Mid(objDataType.PhysicalName,
InStr(objDataType.PhysicalName, "(") + 1, (Len(objDataType.PhysicalName) -
InStr(objDataType.PhysicalName, "(") - 1))
If length 255 Then
Set fld = tdf.CreateField(strName, dbMemo)
Else
Set fld = tdf.CreateField(strName, dbText,
length)
End If

Case "COUNT" 'Autonumber fields
Set fld = tdf.CreateField(strName, dbLong)
fld.Attributes = dbAutoIncrField

'Create DAO fields as required
Case "LONG": Set fld = tdf.CreateField(strName, dbLong)
Case "DOUBL", "DECIM", "NUMER": Set fld =
tdf.CreateField(strName, dbDouble)
Case "INTEG", "SMALL", "SHORT": Set fld =
tdf.CreateField(strName, dbInteger)
Case "SINGL", "REAL": Set fld =
tdf.CreateField(strName,
dbSingle)
Case "DATET": Set fld = tdf.CreateField(strName,
dbDate)
Case "BIT": Set fld = tdf.CreateField(strName,
dbBoolean)
Case "BYTE": Set fld = tdf.CreateField(strName, dbByte)
Case "CURRE": Set fld = tdf.CreateField(strName,
dbCurrency)
Case "FLOAT": Set fld = tdf.CreateField(strName,
dbFloat)
Case "GUID": Set fld = tdf.CreateField(strName, dbGUID)
Case "LONGB": Set fld = tdf.CreateField(strName,
dbLongBinary)
Case "LONGT", "LONGC": Set fld =
tdf.CreateField(strName, dbMemo)
Case "BINAR", "VARBI"
length = Mid(objDataType.PhysicalName,
InStr(objDataType.PhysicalName, "(") + 1, (Len(objDataType.PhysicalName) -
InStr(objDataType.PhysicalName, "(") - 1))
Set fld = tdf.CreateField(strName, dbBinary,
length)
Case Else: length = 1 / 0 'Stop code to enable debug

End Select

'Set field attributes
If objFldDef.AllowNulls = False Then
fld.Required = True
End If

'Save field in DAO table def
tdf.Fields.Append fld

'Select next field in the table definition
Set objFldDef = objTblAttribs.Next

Loop

'Save the new table.
db.TableDefs.Append tdf

'Add Indexes

On Error GoTo IndErr

'Select the indexes in the table definition
Set objIndexes = objTblDef.EntityAnnotations

'Select the first Index in the table definition
Set objIndex = objIndexes.Next

Do While Not objIndex Is Nothing

'Create the Index in the database
Set ind = tdf.CreateIndex(objIndex.PhysicalName)

'Select the first field of the Index Definition
Set objIndexFlds = objIndex.Attributes
Set objIndexFld = objIndexFlds.Next

Do While Not objIndexFld Is Nothing

'Add field to index in database
ind.Fields.Append
ind.CreateField(objIndexFld.PhysicalName)

'Select the next field in the index definition
Set objIndexFld = objIndexFlds.Next

Loop

'Primary Index
If objIndex.kind = eVMEEREntityAnnotationPrimary Then
ind.Primary = True
End If

'Unique Index
If objIndex.kind = eVMEEREntityAnnotationAlternate Then
ind.Unique = True
End If

'Add index to database
tdf.Indexes.Append ind

'Select the next index in the data model
Set objIndex = objIndexes.Next

Loop

End If

Set dwgObj = elements.Next

Loop

'End first pass, Set up for the second pass through the model
On Error GoTo RelErr

Set elements = model.elements
Set dwgObj = elements.Next

Do While Not dwgObj Is Nothing

'Have we got a relationship?
If dwgObj.Type = eVMEKindERRelationship Then

'Add relationships

Set objRltshp = dwgObj

'Create Relationship
Set rel = db.CreateRelation(objRltshp.PhysicalName)

'Define its properties.
With rel

'Specify the primary table. (The child table in VME)
.Table = objRltshp.SecondEntity.PhysicalName

'Specify the related / foreign table. (The parent table in
VME)
.ForeignTable = objRltshp.FirstEntity.PhysicalName

'Specify attributes for cascading updates and deletes.
If objRltshp.UpdateRule = eVMERIRuleCascade Then
.Attributes = dbRelationUpdateCascade
End If

If objRltshp.DeleteRule = eVMERIRuleCascade Then
.Attributes = dbRelationDeleteCascade
End If

'Add the fields to the relationship

'Read Primary table fields
Set objIndexPriFlds = objRltshp.SecondAttributes
Set objIndexPriFld = objIndexPriFlds.Next

'Read Foreign table fields
Set objIndexFrgFlds = objRltshp.FirstAttributes
Set objIndexFrgFld = objIndexFrgFlds.Next

Do While Not objIndexPriFld Is Nothing

'Field name in primary table.
Set fld = .CreateField(objIndexPriFld.PhysicalName)

'Field name in related table.
fld.ForeignName = objIndexFrgFld.PhysicalName

'Append the fields to the relationship
.Fields.Append fld

'Repeat for other fields if a multi-field relation.
Set objIndexPriFld = objIndexPriFlds.Next
Set objIndexFrgFld = objIndexFrgFlds.Next

Loop

End With

'Save the newly defined relation to the Relations collection.
db.Relations.Append rel

End If

Set dwgObj = elements.Next

Loop

Set db = Nothing

Exit Sub

TblErr:
Debug.Print "Tbl Err"
Debug.Print " "
Resume Next

IndErr:
Debug.Print objTblDef.PhysicalName, objIndex.PhysicalName,
Err.Description, "Idx Err"
Debug.Print " "
Resume Next

RelErr:
Debug.Print objRltshp.SecondEntity.PhysicalName,
objRltshp.FirstEntity.PhysicalName, Err.Description, "Rel Err"
Debug.Print " "
Resume Next

End Sub

I have the code compiling in an access module. However, I get stopped at Set
elements = model.elements. I think it is due to no having vme or models set
to a vsd file. What is the correct method to point/open a visio drawing's
master collection?

Should the code be created as a visio vba macro/project in the vba editor.
Then add references to Microsoft DAO Object 3.6 Library? I assume that this
code does not work with Visio Standard, only Pro?

"cgc3iii" wrote:

I have the code compiling in an access module. However, I get stopped at Set
elements = model.elements. I think it is due to no having vme or models set
to a vsd file. What is the correct method to point/open a visio drawing's
master collection?

I have altered the code to generate a SQL DDL script. The tables, indexes
and relationships are included. I have not been successful in getting
column/field defaults out of the visio objects that reference fields/columns.


Any assistance with the IVMEAttribute or correct object to get column
defaults out would be appreciated. Once I get this completed, I will upload
the source.


"Al Edlund" wrote:

Nicely done. I'm sure there are a lot of users out there that will want to
take advantage of it.
al

"JW" wrote in message
...
After trawling through google searching for some vba code to convert a
Visio
2003 Entity Relationship Diagram to a Microsoft Access 2003 Database and
coming up with nothing, I had to generate all the code myself.

The code is fairly idiot proof, hope someone find it useful.


Option Explicit

Const newDBPath As String = "C:\newDB.mdb"

Public Sub New_Db1()

Dim db As DAO.Database

'Visio Modelling Engine
Static vme As New VisioModelingEngine
Dim models As IEnumIVMEModels
Dim model As IVMEModel
Dim elements As IEnumIVMEModelElements
Dim dwgObj As IVMEModelElement

'Tables
Dim objTblDef As IVMEEntity
Dim objTblAttribs As IEnumIVMEAttributes
Dim objFldDef As IVMEAttribute
Dim objDataType As IVMEDataType
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim strName As String

'Indexes
Dim objIndexes As IEnumIVMEEntityAnnotations
Dim objIndex As IVMEEntityAnnotation
Dim objIndexFlds As IEnumIVMEAttributes
Dim objIndexFld As IVMEAttribute
Dim ind As DAO.Index

'Relationships
Dim objRltshp As IVMEBinaryRelationship
Dim objIndexPriFlds As IEnumIVMEAttributes
Dim objIndexPriFld As IVMEAttribute
Dim objIndexFrgFlds As IEnumIVMEAttributes
Dim objIndexFrgFld As IVMEAttribute
Dim rel As DAO.Relation

'Delete existing Database
On Error Resume Next
Kill newDBPath
On Error GoTo 0

'Create new DAO database
Set db = CreateDatabase(newDBPath, dbLangGeneral)

'Set up refernces to entities ie tables and relationships in the visio
modelling engine
Set models = vme.models
Set model = models.Next
Set elements = model.elements
Set dwgObj = elements.Next

On Error GoTo TblErr

'Add tables and indexes
Do While Not dwgObj Is Nothing

'Have we got a table definition?
If dwgObj.Type = eVMEKindEREntity Then

'Add Tables

'Set a refernce to the table definition
Set objTblDef = dwgObj

'Create DAO Table Def
Set tdf = db.CreateTableDef(objTblDef.PhysicalName)

'Set a refernce to the columns category of the table definition
Set objTblAttribs = objTblDef.Attributes

'Select first row of field data in the columns category
Set objFldDef = objTblAttribs.Next

Do While Not objFldDef Is Nothing

'Set a reference to the fields datatype
Set objDataType = objFldDef.DataType

'Get the name of the field
strName = objFldDef.PhysicalName

'Get the name of the fields datatype
Select Case Left(UCase(objDataType.PhysicalName), 5)

Case "TEXT(", "CHAR(", "VARCH"
Dim length As Integer
length = Mid(objDataType.PhysicalName,
InStr(objDataType.PhysicalName, "(") + 1, (Len(objDataType.PhysicalName) -
InStr(objDataType.PhysicalName, "(") - 1))
If length 255 Then
Set fld = tdf.CreateField(strName, dbMemo)
Else
Set fld = tdf.CreateField(strName, dbText,
length)
End If

Case "COUNT" 'Autonumber fields
Set fld = tdf.CreateField(strName, dbLong)
fld.Attributes = dbAutoIncrField

'Create DAO fields as required
Case "LONG": Set fld = tdf.CreateField(strName, dbLong)
Case "DOUBL", "DECIM", "NUMER": Set fld =
tdf.CreateField(strName, dbDouble)
Case "INTEG", "SMALL", "SHORT": Set fld =
tdf.CreateField(strName, dbInteger)
Case "SINGL", "REAL": Set fld =
tdf.CreateField(strName,
dbSingle)
Case "DATET": Set fld = tdf.CreateField(strName,
dbDate)
Case "BIT": Set fld = tdf.CreateField(strName,
dbBoolean)
Case "BYTE": Set fld = tdf.CreateField(strName, dbByte)
Case "CURRE": Set fld = tdf.CreateField(strName,
dbCurrency)
Case "FLOAT": Set fld = tdf.CreateField(strName,
dbFloat)
Case "GUID": Set fld = tdf.CreateField(strName, dbGUID)
Case "LONGB": Set fld = tdf.CreateField(strName,
dbLongBinary)
Case "LONGT", "LONGC": Set fld =
tdf.CreateField(strName, dbMemo)
Case "BINAR", "VARBI"
length = Mid(objDataType.PhysicalName,
InStr(objDataType.PhysicalName, "(") + 1, (Len(objDataType.PhysicalName) -
InStr(objDataType.PhysicalName, "(") - 1))
Set fld = tdf.CreateField(strName, dbBinary,
length)
Case Else: length = 1 / 0 'Stop code to enable debug

End Select

'Set field attributes
If objFldDef.AllowNulls = False Then
fld.Required = True
End If

'Save field in DAO table def
tdf.Fields.Append fld

'Select next field in the table definition
Set objFldDef = objTblAttribs.Next

Loop

'Save the new table.
db.TableDefs.Append tdf

'Add Indexes

On Error GoTo IndErr

'Select the indexes in the table definition
Set objIndexes = objTblDef.EntityAnnotations

'Select the first Index in the table definition
Set objIndex = objIndexes.Next

Do While Not objIndex Is Nothing

'Create the Index in the database
Set ind = tdf.CreateIndex(objIndex.PhysicalName)

'Select the first field of the Index Definition
Set objIndexFlds = objIndex.Attributes
Set objIndexFld = objIndexFlds.Next

Do While Not objIndexFld Is Nothing

'Add field to index in database
ind.Fields.Append
ind.CreateField(objIndexFld.PhysicalName)

'Select the next field in the index definition
Set objIndexFld = objIndexFlds.Next

Loop

'Primary Index
If objIndex.kind = eVMEEREntityAnnotationPrimary Then
ind.Primary = True
End If

'Unique Index
If objIndex.kind = eVMEEREntityAnnotationAlternate Then
ind.Unique = True
End If

'Add index to database
tdf.Indexes.Append ind

'Select the next index in the data model
Set objIndex = objIndexes.Next

Loop

End If

Set dwgObj = elements.Next

Loop

'End first pass, Set up for the second pass through the model
On Error GoTo RelErr

Set elements = model.elements
Set dwgObj = elements.Next

Do While Not dwgObj Is Nothing

'Have we got a relationship?
If dwgObj.Type = eVMEKindERRelationship Then

'Add relationships

Set objRltshp = dwgObj

'Create Relationship
Set rel = db.CreateRelation(objRltshp.PhysicalName)

'Define its properties.
With rel

'Specify the primary table. (The child table in VME)
.Table = objRltshp.SecondEntity.PhysicalName

'Specify the related / foreign table. (The parent table in
VME)
.ForeignTable = objRltshp.FirstEntity.PhysicalName

'Specify attributes for cascading updates and deletes.
If objRltshp.UpdateRule = eVMERIRuleCascade Then
.Attributes = dbRelationUpdateCascade
End If

If objRltshp.DeleteRule = eVMERIRuleCascade Then
.Attributes = dbRelationDeleteCascade
End If

'Add the fields to the relationship

'Read Primary table fields
Set objIndexPriFlds = objRltshp.SecondAttributes
Set objIndexPriFld = objIndexPriFlds.Next

'Read Foreign table fields
Set objIndexFrgFlds = objRltshp.FirstAttributes
Set objIndexFrgFld = objIndexFrgFlds.Next

Do While Not objIndexPriFld Is Nothing

'Field name in primary table.
Set fld = .CreateField(objIndexPriFld.PhysicalName)

'Field name in related table.
fld.ForeignName = objIndexFrgFld.PhysicalName

'Append the fields to the relationship
.Fields.Append fld

'Repeat for other fields if a multi-field relation.
Set objIndexPriFld = objIndexPriFlds.Next
Set objIndexFrgFld = objIndexFrgFlds.Next

Loop

End With

'Save the newly defined relation to the Relations collection.
db.Relations.Append rel

End If

Set dwgObj = elements.Next

Loop

Set db = Nothing

Exit Sub

TblErr:

I too ran into the error at elements = model.elements. When I look at the properties of "model" in the locals window, they all say Automation Error. The "Models" and "vme" objects all appear to be empty. Did you get this code running at all? It would be VERY useful.



cgc3ii wrote:

I have the code compiling in an access module.
24-Jun-08

I have the code compiling in an access module. However, I get stopped at Set
elements = model.elements. I think it is due to no having vme or models set
to a vsd file. What is the correct method to point/open a visio drawing's
master collection?

Previous Posts In This Thread:

On Thursday, May 01, 2008 10:32 AM
J wrote:

Forward Engineer Visio ER Diagram to MS Access Database
After trawling through google searching for some vba code to convert a Visio
2003 Entity Relationship Diagram to a Microsoft Access 2003 Database and
coming up with nothing, I had to generate all the code myself.

The code is fairly idiot proof, hope someone find it useful.


Option Explicit

Const newDBPath As String = "C:\newDB.mdb"

Public Sub New_Db1()

Dim db As DAO.Database

'Visio Modelling Engine
Static vme As New VisioModelingEngine
Dim models As IEnumIVMEModels
Dim model As IVMEModel
Dim elements As IEnumIVMEModelElements
Dim dwgObj As IVMEModelElement

'Tables
Dim objTblDef As IVMEEntity
Dim objTblAttribs As IEnumIVMEAttributes
Dim objFldDef As IVMEAttribute
Dim objDataType As IVMEDataType
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim strName As String

'Indexes
Dim objIndexes As IEnumIVMEEntityAnnotations
Dim objIndex As IVMEEntityAnnotation
Dim objIndexFlds As IEnumIVMEAttributes
Dim objIndexFld As IVMEAttribute
Dim ind As DAO.Index

'Relationships
Dim objRltshp As IVMEBinaryRelationship
Dim objIndexPriFlds As IEnumIVMEAttributes
Dim objIndexPriFld As IVMEAttribute
Dim objIndexFrgFlds As IEnumIVMEAttributes
Dim objIndexFrgFld As IVMEAttribute
Dim rel As DAO.Relation

'Delete existing Database
On Error Resume Next
Kill newDBPath
On Error GoTo 0

'Create new DAO database
Set db = CreateDatabase(newDBPath, dbLangGeneral)

'Set up refernces to entities ie tables and relationships in the visio
modelling engine
Set models = vme.models
Set model = models.Next
Set elements = model.elements
Set dwgObj = elements.Next

On Error GoTo TblErr

'Add tables and indexes
Do While Not dwgObj Is Nothing

'Have we got a table definition?
If dwgObj.Type = eVMEKindEREntity Then

'Add Tables

'Set a refernce to the table definition
Set objTblDef = dwgObj

'Create DAO Table Def
Set tdf = db.CreateTableDef(objTblDef.PhysicalName)

'Set a refernce to the columns category of the table definition
Set objTblAttribs = objTblDef.Attributes

'Select first row of field data in the columns category
Set objFldDef = objTblAttribs.Next

Do While Not objFldDef Is Nothing

'Set a reference to the fields datatype
Set objDataType = objFldDef.DataType

'Get the name of the field
strName = objFldDef.PhysicalName

'Get the name of the fields datatype
Select Case Left(UCase(objDataType.PhysicalName), 5)

Case "TEXT(", "CHAR(", "VARCH"
Dim length As Integer
length = Mid(objDataType.PhysicalName,
InStr(objDataType.PhysicalName, "(") + 1, (Len(objDataType.PhysicalName) -
InStr(objDataType.PhysicalName, "(") - 1))
If length 255 Then
Set fld = tdf.CreateField(strName, dbMemo)
Else
Set fld = tdf.CreateField(strName, dbText, length)
End If

Case "COUNT" 'Autonumber fields
Set fld = tdf.CreateField(strName, dbLong)
fld.Attributes = dbAutoIncrField

'Create DAO fields as required
Case "LONG": Set fld = tdf.CreateField(strName, dbLong)
Case "DOUBL", "DECIM", "NUMER": Set fld =
tdf.CreateField(strName, dbDouble)
Case "INTEG", "SMALL", "SHORT": Set fld =
tdf.CreateField(strName, dbInteger)
Case "SINGL", "REAL": Set fld = tdf.CreateField(strName,
dbSingle)
Case "DATET": Set fld = tdf.CreateField(strName, dbDate)
Case "BIT": Set fld = tdf.CreateField(strName, dbBoolean)
Case "BYTE": Set fld = tdf.CreateField(strName, dbByte)
Case "CURRE": Set fld = tdf.CreateField(strName,
dbCurrency)
Case "FLOAT": Set fld = tdf.CreateField(strName, dbFloat)
Case "GUID": Set fld = tdf.CreateField(strName, dbGUID)
Case "LONGB": Set fld = tdf.CreateField(strName,
dbLongBinary)
Case "LONGT", "LONGC": Set fld =
tdf.CreateField(strName, dbMemo)
Case "BINAR", "VARBI"
length = Mid(objDataType.PhysicalName,
InStr(objDataType.PhysicalName, "(") + 1, (Len(objDataType.PhysicalName) -
InStr(objDataType.PhysicalName, "(") - 1))
Set fld = tdf.CreateField(strName, dbBinary, length)
Case Else: length = 1 / 0 'Stop code to enable debug

End Select

'Set field attributes
If objFldDef.AllowNulls = False Then
fld.Required = True
End If

'Save field in DAO table def
tdf.Fields.Append fld

'Select next field in the table definition
Set objFldDef = objTblAttribs.Next

Loop

'Save the new table.
db.TableDefs.Append tdf

'Add Indexes

On Error GoTo IndErr

'Select the indexes in the table definition
Set objIndexes = objTblDef.EntityAnnotations

'Select the first Index in the table definition
Set objIndex = objIndexes.Next

Do While Not objIndex Is Nothing

'Create the Index in the database
Set ind = tdf.CreateIndex(objIndex.PhysicalName)

'Select the first field of the Index Definition
Set objIndexFlds = objIndex.Attributes
Set objIndexFld = objIndexFlds.Next

Do While Not objIndexFld Is Nothing

'Add field to index in database
ind.Fields.Append
ind.CreateField(objIndexFld.PhysicalName)

'Select the next field in the index definition
Set objIndexFld = objIndexFlds.Next

Loop

'Primary Index
If objIndex.kind = eVMEEREntityAnnotationPrimary Then
ind.Primary = True
End If

'Unique Index
If objIndex.kind = eVMEEREntityAnnotationAlternate Then
ind.Unique = True
End If

'Add index to database
tdf.Indexes.Append ind

'Select the next index in the data model
Set objIndex = objIndexes.Next

Loop

End If

Set dwgObj = elements.Next

Loop

'End first pass, Set up for the second pass through the model
On Error GoTo RelErr

Set elements = model.elements
Set dwgObj = elements.Next

Do While Not dwgObj Is Nothing

'Have we got a relationship?
If dwgObj.Type = eVMEKindERRelationship Then

'Add relationships

Set objRltshp = dwgObj

'Create Relationship
Set rel = db.CreateRelation(objRltshp.PhysicalName)

'Define its properties.
With rel

'Specify the primary table. (The child table in VME)
.Table = objRltshp.SecondEntity.PhysicalName

'Specify the related / foreign table. (The parent table in
VME)
.ForeignTable = objRltshp.FirstEntity.PhysicalName

'Specify attributes for cascading updates and deletes.
If objRltshp.UpdateRule = eVMERIRuleCascade Then
.Attributes = dbRelationUpdateCascade
End If

If objRltshp.DeleteRule = eVMERIRuleCascade Then
.Attributes = dbRelationDeleteCascade
End If

'Add the fields to the relationship

'Read Primary table fields
Set objIndexPriFlds = objRltshp.SecondAttributes
Set objIndexPriFld = objIndexPriFlds.Next

'Read Foreign table fields
Set objIndexFrgFlds = objRltshp.FirstAttributes
Set objIndexFrgFld = objIndexFrgFlds.Next

Do While Not objIndexPriFld Is Nothing

'Field name in primary table.
Set fld = .CreateField(objIndexPriFld.PhysicalName)

'Field name in related table.
fld.ForeignName = objIndexFrgFld.PhysicalName

'Append the fields to the relationship
.Fields.Append fld

'Repeat for other fields if a multi-field relation.
Set objIndexPriFld = objIndexPriFlds.Next
Set objIndexFrgFld = objIndexFrgFlds.Next

Loop

End With

'Save the newly defined relation to the Relations collection.
db.Relations.Append rel

End If

Set dwgObj = elements.Next

Loop

Set db = Nothing

Exit Sub

TblErr:
Debug.Print "Tbl Err"
Debug.Print " "
Resume Next

IndErr:
Debug.Print objTblDef.PhysicalName, objIndex.PhysicalName,
Err.Description, "Idx Err"
Debug.Print " "
Resume Next

RelErr:
Debug.Print objRltshp.SecondEntity.PhysicalName,
objRltshp.FirstEntity.PhysicalName, Err.Description, "Rel Err"
Debug.Print " "
Resume Next

End Sub

On Thursday, May 01, 2008 12:01 PM
Al Edlund wrote:

Nicely done.
Nicely done. I am sure there are a lot of users out there that will want to
take advantage of it.
al

On Tuesday, June 24, 2008 8:34 AM
cgc3ii wrote:

I have the code compiling in an access module.
I have the code compiling in an access module. However, I get stopped at Set
elements = model.elements. I think it is due to no having vme or models set
to a vsd file. What is the correct method to point/open a visio drawing's
master collection?

On Tuesday, June 24, 2008 10:13 AM
cgc3ii wrote:

Should the code be created as a visio vba macro/project in the vba editor.
Should the code be created as a visio vba macro/project in the vba editor.
Then add references to Microsoft DAO Object 3.6 Library? I assume that this
code does not work with Visio Standard, only Pro?

"cgc3iii" wrote:

On Friday, June 27, 2008 1:54 PM
cgc3ii wrote:

I have altered the code to generate a SQL DDL script.
I have altered the code to generate a SQL DDL script. The tables, indexes
and relationships are included. I have not been successful in getting
column/field defaults out of the visio objects that reference fields/columns.


Any assistance with the IVMEAttribute or correct object to get column
defaults out would be appreciated. Once I get this completed, I will upload
the source.


"Al Edlund" wrote:


Submitted via EggHeadCafe - Software Developer Portal of Choice
Fun With OPML in ASP.NET
http://www.eggheadcafe.com/tutorials...in-aspnet.aspx