VBA on Visio

_____ผมเองก็เป็นอีกคนที่ชอบใช้ Visio ในการเขียน Flowchart หรือ Diagram อาจจะเป็นเพราะคุ้นเคยหรือไงไม่ทราบ ใช้มากี่ปีก็ยังไม่ได้เปลี่ยนซักที วันนี้ไปเจอ code ที่เค้าใช้เขียน VBA ใน VISIO เพื่อแปลง Er-diagram ไปเป็น Microsoft Access 2003 Database Schema ขอเอามาแปะไว้เพื่อว่าท่านใดที่ใช้ Visio และอยากลองเอาไปใช้งานได้หรือจะ apply ไปใช้กับ DBA ตัวอื่น เช่น SQLSERVER หรือ POSTGRESQL ก็ได้

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

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

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

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)
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,
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,
Case "FLOAT": Set fld = tdf.CreateField(strName, dbFloat)
Case "GUID": Set fld = tdf.CreateField(strName, dbGUID)
Case "LONGB": Set fld = tdf.CreateField(strName,
Case "LONGT", "LONGC": Set fld =
tdf.CreateField(strName, dbMemo)
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


'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

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


'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


End If

Set dwgObj = elements.Next


'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
.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


End With

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

End If

Set dwgObj = elements.Next


Set db = Nothing

Exit Sub

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

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

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

End Sub



Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / เปลี่ยนแปลง )

Twitter picture

You are commenting using your Twitter account. Log Out / เปลี่ยนแปลง )

Facebook photo

You are commenting using your Facebook account. Log Out / เปลี่ยนแปลง )

Google+ photo

You are commenting using your Google+ account. Log Out / เปลี่ยนแปลง )

Connecting to %s

สร้างเว็บไซต์หรือบล็อกฟรีที่ WordPress.com.

Up ↑

%d bloggers like this: