J
JW
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
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