12,665
回編集
差分
ナビゲーションに移動
検索に移動
ページの作成:「==Visio ER図の情報を取得する== [Visio][VBA] *http://msdn.microsoft.com/ja-jp/library/cc377254.aspx ===モジュール=== VisioのER図をCSV出力する…」
==Visio ER図の情報を取得する==
[Visio][VBA]
*http://msdn.microsoft.com/ja-jp/library/cc377254.aspx
===モジュール===
VisioのER図をCSV出力するマクロ
{{ref MakeVisioEntityList.zip}}
<blockquote>メタ情報が取得しかたがわからない(そもそもできる？)。。。</blockquote>
'ログ出力の抑制
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
[Visio][VBA]
*http://msdn.microsoft.com/ja-jp/library/cc377254.aspx
===モジュール===
VisioのER図をCSV出力するマクロ
{{ref MakeVisioEntityList.zip}}
<blockquote>メタ情報が取得しかたがわからない(そもそもできる？)。。。</blockquote>
'ログ出力の抑制
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
© 2006 矢木浩人
