Visio Database maken

[harolda1980]

Ik heb mijn database vorm gegevens in Visio 2007. Kun je deze ook uitvoeren naar ene gewenst *.mdb model.

Ik ben benieuwd..

 

[maniac2003]

Kijkend in mijn Office 2010 zie ik die optie niet.

 

[Jarcol]

Een beetje laat...

Ik heb mijn database vorm gegevens in Visio 2007. Kun je deze ook uitvoeren naar ene gewenst *.mdb model.

Ik ben benieuwd..

Het is een beetje laat, maar misschien heb je hier nog wat aan.

Ik liep een tijd geleden tegen hetzelfde probleem aan en heb toen gezocht naar een oplossing. Er was toen iemand die in VB (macro in Visio) een script geschreven heeft die op basis van het model in Visio een *.mdb opbouwde.

De code is:

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

Ik hoop dat je er nog wat aan hebt!