Visio ER図の情報を取得する

Visio ER図の情報を取得する

[Visio][VBA]

• http://msdn.microsoft.com/ja-jp/library/cc377254.aspx

 モジュール

VisioのER図をCSV出力するマクロ
MakeVisioEntityList.zip(487)

メタ情報が取得しかたがわからない(そもそもできる？)。。。

'ログ出力の抑制
Private Const IS_LOGGING As Boolean = True

'除外するVisioシート名(一部一致をカンマ区切り)
Private Const EXCEPT_SHEET_KEYWORD As String = "背景"

'エンティティを識別するためのマスターシェイプ名
Private Const MASTER_SHAPE_ENTITY_NAME_U As String = "Entity"

'
' 主処理
'
Sub main()
    Dim docPages    As Pages
    Dim docPage     As Page
    Dim docPageCnt  As Integer
    Dim i           As Integer
    
    
    Dim entityDict  As Object   'Entityを保持するMap
    
    Set entityDict = CreateObject("Scripting.Dictionary")
    
    'Visioドキュメントのページ単位で処理
    Set docPages = Application.ActiveDocument.Pages
    docPageCnt = docPages.Count
    
    For i = 1 To docPageCnt
        'Entity辞書のクリア
        Call entityDict.RemoveAll
        
        Set docPage = docPages.Item(i)
        If Not IsExceptSheet(docPage.Name) Then
            Call ParsePage(docPage, entityDict)
        End If
        
        ' TODO
        '
        ' ここで、entityDict に 結果 {テーブル名:テーブルオブジェクト}
        ' が格納されるので、なんらかの処理(ファイル出力など)を行う
        '
        '
        
    Next
End Sub
'
' シートごとの処理
'
Private Sub ParsePage(ByRef docPage As Page, ByRef entityDict As Object)
    
    Dim docShapes       As Shapes
    Dim docShapeCnt     As Integer
    Dim i               As Integer
    Dim docShapeNameU   As String
    
    Set docShapes = docPage.Shapes
    docShapeCnt = docShapes.Count
    
    For i = 1 To docShapeCnt
        docShapeNameU = docShapes(i).NameU
        
        Select Case True
        Case InStr(1, docShapeNameU, MASTER_SHAPE_ENTITY_NAME_U) = 1
            ' テーブル、列、データ型
            Call ProcEntity(docShapes(i), entityDict)
        Case Else
            'Debug.Print docShapeNameU
        End Select
        
    Next
End Sub
'
' エンティティ処理
'
Private Sub ProcEntity(ByRef entityShape As Shape, ByRef entityDict As Object)
    Dim partsShapes     As Shapes
    Dim partsShape      As Shape
    Dim explainShape    As Shape
    Dim partsShapeCnt   As Integer
    Dim i               As Integer
    Dim j               As Integer
    Dim ent             As Entity
    Dim col             As Column
    Dim rareRow()       As String
    Dim splitedRow()    As String
    
    Set partsShapes = entityShape.Shapes
    partsShapeCnt = partsShapes.Count
    
    For i = 1 To partsShapeCnt
    
        Set partsShape = partsShapes(i)
        Select Case i
        Case 1
            ' テーブル名
            Set ent = New Entity
            ent.Name = partsShape.Text
            
            If entityDict.Exists(ent.Name) Then
                'TODO Duplicated
                Call MsgBox("重複" + ent.Name)
            Else
                Call entityDict.Add(ent.Name, ent)
            End If
            
            Call Logging(vbCrLf & ent.Name)
            
        Case 2
            '2:列情報
            rareRow = Split(partsShape.Text, vbLf)
            For j = LBound(rareRow) To UBound(rareRow)
                splitedRow = SplitRow(rareRow(j))
                
                Set col = New Column
                col.Name = splitedRow(0)
                col.DataType = splitedRow(1)
                
                If Trim(col.Name) <> "" Then
                    Call ent.AddColumn(col)
                End If
                Call Logging(vbTab & col.Name & " " & col.DataType)
            Next
        End Select
    Next
    
End Sub
'
' 列名とデータ型を分ける
'
Private Function SplitRow(ByRef row As String) As String()
    Const COL_SEP_CHAR As String = vbTab
    Dim sepPos          As Integer
    Dim i               As Integer
    Dim c               As String
    Dim ret(0 To 1)     As String
    Dim tmp()           As String
    
    ret(0) = ""
    ret(1) = ""
    
    If Trim(row) <> "" Then
        tmp = Split(row, COL_SEP_CHAR)
        
        If UBound(tmp) > 0 Then
            ret(0) = Trim(tmp(0))
            ret(1) = Trim(tmp(1))
        Else
            ret(0) = Trim(row)
        End If
    End If
    SplitRow = ret

End Function
'
' 除外シートのチェック
'
Private Function IsExceptSheet(sheetName As String) As Boolean
    Dim keywords()  As String
    Dim ret         As Boolean
    Dim i           As Integer
    
    keywords = Split(EXCEPT_SHEET_KEYWORD, ",")

    For i = LBound(keywords) To UBound(keywords)
        ret = InStr(sheetName, keywords(i)) > 0
        If ret Then
            Exit For
        End If
    Next

    IsExceptSheet = ret
End Function
'
' ログ
'
Private Sub Logging(log As String)
    If IS_LOGGING Then
        Debug.Print log
    End If
End Sub

 クラス

Column

Private mName       As String
Private mDataType   As String
Private mExplain    As String


Public Property Get Name() As String
    Name = mName
End Property

Public Property Let Name(ByVal newName As String)
    mName = newName
End Property

Public Property Get DataType() As String
    DataType = mDataType
End Property

Public Property Let DataType(ByVal newDataType As String)
    mDataType = newDataType
End Property

Public Property Get Explain() As String
    Explain = mExplain
End Property

Public Property Let Explain(ByVal newExplain As String)
    mExplain = newExplain
End Property

Entity

Private mName       As String
Private mColumns()  As Column
Private mColumnCnt  As Integer


Public Property Get Name() As String
    Name = mName
End Property

Public Property Let Name(ByVal newName As String)
    mName = newName
End Property

Public Property Get Columns() As Column()
    Columns = mColumns
End Property
Public Property Let Columns(ByRef newColumns() As Column)
    Set mColumns = newColumns
End Property


Public Sub AddColumn(ByRef col As Column)

    
    ReDim Preserve mColumns(mColumnCnt)
    
    Set mColumns(mColumnCnt) = col

    mColumnCnt = mColumnCnt + 1
End Sub

Private Sub Class_Initialize()
    mColumnCnt = 0
End Sub