要件
テーブル定義で主キーと外部キーがあれば、論理上ER図が自動的に作成されるが
ＶＢＡのマクロで位置の配置、線の引きはどう工夫すればいいか
設計
テーブルが勝手に７＊Nマスにおける
位置調整
マス位置に対し、関係が緊密(外部キーの多少と距離）なテーブルを近づくようにチューニングする
任意マスAのX方向、Y方向引く力Fax、Fayを計算
Fax = Sum（Aの外部キーマスNのX方向距離）
Fay = Sum（Aの外部キーマスNのY方向距離）
右マスBののX方向引く力Fbxを計算
Fbx = Sum（B外部キーマスNのX方向距離）
Fax＞Fbxの場合、マスAとマスBに位置を交換する
下のマスCのY方向力を計算し、同じように位置交換を行う
・全マスが何回ループし、位置が固定される
結果として、関係緊密のテーブルが真ん中に移動される
・繋ぐ線の引くはできる限りマスとダブルしない、通路のところに引く
実装
Public Sub createER()
'Entities dic
Dim entDic As Object
Dim fieldShpDic As Object
Dim fieldDic As Object
Dim defsht As Object
Dim objsht As Object
Dim targetsht As Object
Dim i, j, k, cnt As Integer
Dim tmpObj As String
Dim curObj As String
Dim leftObj As String
Dim underObj As String
Dim pkDic As Object
Dim fkDic As Object
Dim shpXy As Object
Dim xyShp As Object
Set entDic = CreateObject("Scripting.Dictionary")
Set defsht = Sheets("一覧")
Set targetsht = Sheets("ER図")
todayDate = Format(Now, "yyyymmddhhmmss")
targetsht.Copy After:=Sheets("ER図")
ActiveSheet.Name = "ER図_" & todayDate
targetsht.Select
i = 2
cnt = 0
While defsht.Cells(i, 1) <> ""
If defsht.Cells(i, 5) = "R" Then
tmpObj = defsht.Cells(i, 2)
entDic.Add tmpObj, defsht.Cells(i, 1)
cnt = cnt + 1
End If
i = i + 1
Wend
'
If cnt = 0 Then
MsgBox "E列目にRを付けて、ER図を作成します。"
Exit Sub
End If
'relations fields dic
Set fieldDic = CreateObject("Scripting.Dictionary")
Set fkDic = CreateObject("Scripting.Dictionary")
Set pkDic = CreateObject("Scripting.Dictionary")
Dim vKey As Variant
Dim shtnm As String
Dim strEr As String
strEr = ""
For Each vKey In entDic.keys
shtnm = entDic.Item(vKey)
Set objsht = Sheets(shtnm)
strEr = strEr & "entity """ & shtnm & """ as " & vKey & " {" & vbCrLf
j = 5
While objsht.Cells(j, 1) <> ""
strEr = strEr & " " & objsht.Cells(j, 2)
tmpObj = objsht.Cells(j, 4)
If Left(tmpObj, 4) = "参照関係" Then
relObj = Replace(tmpObj, "参照関係(", "")
relObj = Replace(relObj, ")", "")
'SelfRelation 除く
If relObj <> vKey And entDic.exists(relObj) = True Then
fieldDic.Add vKey & "####" & objsht.Cells(j, 3) & "####" & objsht.Cells(j, 2), relObj
'foreign key
If Not fkDic.exists(vKey) Then
fkDic.Add vKey, relObj
Else
fkDic.Item(vKey) = fkDic.Item(vKey) & "###" & relObj
End If
'primary key
If Not pkDic.exists(relObj) Then
pkDic.Add relObj, vKey
Else
pkDic.Item(relObj) = pkDic.Item(relObj) & "###" & vKey
End If
End If
strEr = strEr & "<<FK>>"
End If
strEr = strEr & vbCrLf
If j = 5 Then strEr = strEr & "--" & vbCrLf
j = j + 1
Wend
strEr = strEr & "}" & vbCrLf & vbCrLf
Next
'plantUMLの形式で出力する
strUml = ""
strUml = strUml & "@startuml POWeR-ER" & vbCrLf
strUml = strUml & "Title POWeRプロジェクトER図 " & vbCrLf
strUml = strUml & "skinparam dpi 150" & vbCrLf
strUml = strUml & "hide circle" & vbCrLf
strUml = strUml & "skinparam linetype ortho" & vbCrLf
strUml = strUml & strEr
'plantUml elations
For Each vKey In fieldDic.keys
kary = Split(vKey, "####")
pObj = fieldDic.Item(vKey)
strUml = strUml & pObj & " ||--o{ " & kary(0) & vbCrLf
Next
strUml = strUml & "@enduml" & vbCrLf
'output
toFile = ActiveWorkbook.Path
toFile = toFile & "\SimithEr.plantml"
Set fso = CreateObject("Scripting.FileSystemObject")
Set tfo = fso.OpenTextFile(toFile, 2, True, -1)
tfo.Write strUml
tfo.Close
Set tfo = Nothing
Set fso = Nothing
'list field
'old shapes
'Set fieldOldShpDic = CreateObject("Scripting.Dictionary")
For Each shp In ActiveSheet.Shapes
shp.Delete
Next
'draw object and relation field
Dim shpObj As Object
Dim shpFld As Object
x0 = 100
y0 = 100
wd = 130
wl = 240
wlf = 18
dx = 240
dy = 300
lnWd = 15
lnHd = 9
i = 0
j = 0
Set fieldShpDic = CreateObject("Scripting.Dictionary")
Set shpXy = CreateObject("Scripting.Dictionary")
Set xyShp = CreateObject("Scripting.Dictionary")
grpStr = ""
For Each objKey In entDic.keys
' group the objects
If i = 0 And j = 0 And grpStr = "" Then
i = i
Else
ActiveSheet.Shapes.Range(Split(grpStr, "####")).Select
Selection.ShapeRange.Group.Name = Split(grpStr, "####")(0) & "_GRP"
End If
Set shpObj = ActiveSheet.Shapes.AddShape(msoShapeRectangle, x0 + i * dx, y0 + j * dy, wd, wl)
shpObj.Name = objKey
shpObj.Select
shpXy.Add objKey, i & ":" & j
xyShp.Add i & ":" & j, objKey
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 0.5
End With
'Selection.ShapeRange.Fill.Visible = msoFalse
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.0500000007
.Transparency = 0
.Solid
End With
grpStr = shpObj.Name
Set shpFld = ActiveSheet.Shapes.AddShape(msoShapeRectangle, x0 + i * dx, y0 + j * dy, wd, wlf)
shpFld.Name = objKey & ".Id"
grpStr = grpStr & "####" & shpFld.Name
'add shape
fieldShpDic.Add objKey & ".Id", shpFld
shpFld.Select
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 0.5
End With
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = entDic.Item(objKey)
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
'draw field
k = 1
For Each vKey In fieldDic
kary = Split(vKey, "####")
If objKey = kary(0) Then
Set shpFld = ActiveSheet.Shapes.AddShape(msoShapeRectangle, x0 + i * dx, y0 + j * dy + wlf * k, _
wd, wlf)
shpFld.Name = kary(0) & "." & kary(1)
'group string
grpStr = grpStr & "####" & shpFld.Name
shpFld.Select
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 0
End With
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFalse
Selection.ShapeRange.TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = kary(2)
'add shape dic
fieldShpDic.Add shpFld.Name, shpFld
k = k + 1
End If
Next
i = i + 1
If i > 6 Then
i = 0
j = j + 1
End If
Next
ActiveSheet.Shapes.Range(Split(grpStr, "####")).Select
Selection.ShapeRange.Group.Name = Split(grpStr, "####")(0) & "_GRP"
'tuning position of tables
For kk = 1 To 30
For Each vKey In entDic.keys
'neighber point
curObj = vKey
curIj = shpXy.Item(vKey)
curI = Split(curIj, ":")(0)
curJ = Split(curIj, ":")(1)
leftJ = curJ
leftI = curI + 1
If Not xyShp.exists(leftI & ":" & leftJ) Then
leftI = curI
leftObj = curObj
Else
leftObj = xyShp.Item(leftI & ":" & leftJ)
End If
underI = curI
underJ = curJ + 1
If Not xyShp.exists(underI & ":" & underJ) Then
underJ = curJ
underObj = curObj
Else
underObj = xyShp.Item(underI & ":" & underJ)
End If
'move force
curFi = getForceIJ(curObj, fkDic, pkDic, shpXy, xyShp, 0)
curFj = getForceIJ(curObj, fkDic, pkDic, shpXy, xyShp, 1)
leftFi = getForceIJ(leftObj, fkDic, pkDic, shpXy, xyShp, 0)
underFj = getForceIJ(underObj, fkDic, pkDic, shpXy, xyShp, 1)
If kk = 3 And curObj = "ProductHierarchy__c" Then
curIj = curIj
End If
'compare force
If curFj - underFj > curFi - leftFi Then
If curFj > underFj Then
'move down
shpXy.Item(underObj) = curIj
shpXy.Item(curObj) = underI & ":" & underJ
xyShp.Item(curIj) = underObj
xyShp.Item(underI & ":" & underJ) = curObj
ActiveSheet.Shapes(curObj & "_GRP").IncrementTop (underJ - curJ) * dy
ActiveSheet.Shapes(underObj & "_GRP").IncrementTop -(underJ - curJ) * dy
End If
Else
If curFi > leftFi Then
'move left
shpXy.Item(leftObj) = curIj
shpXy.Item(curObj) = leftI & ":" & leftJ
xyShp.Item(curIj) = leftObj
xyShp.Item(leftI & ":" & leftJ) = curObj
ActiveSheet.Shapes(curObj & "_GRP").IncrementLeft (leftI - curI) * dx
ActiveSheet.Shapes(leftObj & "_GRP").IncrementLeft -(leftI - curI) * dx
End If
End If
Next
Next kk
'draw relation
For Each vKey In fieldDic.keys
kary = Split(vKey, "####")
pObjId = fieldDic.Item(vKey) & ".Id"
Set lineSet = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, 100, 229, 230, 467)
lineSet.Select
Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadOval
bgIj = shpXy(fieldDic.Item(vKey))
edIj = shpXy(kary(0))
dti = Split(bgIj, ":")(0) - Split(edIj, ":")(0)
dtj = Abs(Split(edIj, ":")(1) - Split(bgIj, ":")(1))
k3Flg = 0
If ActiveSheet.Shapes(pObjId).Left > ActiveSheet.Shapes(kary(0)).Left Then
Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes(pObjId), 1
Selection.ShapeRange.ConnectorFormat.EndConnect ActiveSheet.Shapes(kary(0) & "." & kary(1)), 4
itm = 0# + (dti * dx - wd / 2 - lnWd * dti - 2 * dtj) / (dti * dx - wd / 2)
If Selection.ShapeRange.Adjustments.Count = 0 Then
'調整線が２調整点のため、下辺に連線
Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes(pObjId), 3
k3Flg = 1
End If
If Selection.ShapeRange.Adjustments.Count = 1 Then Selection.ShapeRange.Adjustments.Item(1) = itm
If Selection.ShapeRange.Adjustments.Count = 2 Then
Selection.ShapeRange.Adjustments.Item(2) = itm
itm1 = 0# - (dtj * lnHd + wlf) / (dtj * dy + 4 * wlf)
Selection.ShapeRange.Adjustments.Item(1) = itm1
If k3Flg = 1 Then
Selection.ShapeRange.Adjustments.Item(1) = -2 * itm1
End If
End If
Else
If ActiveSheet.Shapes(pObjId).Left = ActiveSheet.Shapes(kary(0)).Left Then
Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes(pObjId), 2
Selection.ShapeRange.ConnectorFormat.EndConnect ActiveSheet.Shapes(kary(0) & "." & kary(1)), 2
Selection.ShapeRange.Adjustments.Item(1) = Selection.ShapeRange.Adjustments.Item(1) + dtj * 6
Else
Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes(pObjId), 1
Selection.ShapeRange.ConnectorFormat.EndConnect ActiveSheet.Shapes(kary(0) & "." & kary(1)), 2
bgIj = shpXy(fieldDic.Item(vKey))
If Selection.ShapeRange.Adjustments.Count = 0 Then
Selection.ShapeRange.ConnectorFormat.BeginConnect ActiveSheet.Shapes(pObjId), 3
k3Flg = 1
Selection.ShapeRange.ZOrder msoBringToFront
End If
If Selection.ShapeRange.Adjustments.Count = 1 Then Selection.ShapeRange.Adjustments.Item(1) = itm
If Selection.ShapeRange.Adjustments.Count = 2 Then
Selection.ShapeRange.Adjustments.Item(2) = itm
itm1 = 0# - (dtj * lnHd + wlf) / (dtj * dy + 4 * wlf)
Selection.ShapeRange.Adjustments.Item(1) = itm1
If k3Flg = 1 Then
Selection.ShapeRange.Adjustments.Item(1) = -2 * itm1
End If
End If
End If
End If
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 0.5
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.EndArrowheadLength = msoArrowheadLong
.EndArrowheadWidth = msoArrowheadWide
End With
'Key の下辺の連線の場合、グループが線の一番前に移動する
If k3Flg = 1 Then
ActiveSheet.Shapes.Range(fieldDic.Item(vKey) & "_GRP").Select
Selection.ShapeRange.ZOrder msoBringToFront
End If
Next
End Sub
Public Function getForceIJ(obj As String, fkDic As Object, pkDic As Object, shpXy As Object, xyShp As Object, ij As Integer) As Integer
'ij = 0 x direction
'ij = 1 y direction
getForceIJ = 0
curI = Split(shpXy.Item(obj), ":")(ij)
'fk
For Each fk In Split(fkDic.Item(obj), "###")
fki = Split(shpXy.Item(fk), ":")(ij)
getForceIJ = getForceIJ + (fki - curI)
Next
'pk
For Each pk In Split(pkDic.Item(obj), "###")
pki = Split(shpXy.Item(pk), ":")(ij)
getForceIJ = getForceIJ + (pki - curI)
Next
End Function
操作説明
一覧例
E列に関係あるものに「R」をマークして、「ER図作成」ボタンをクリックする
明細シート例
ちなみにこれもマクロで自動的に環境から取得されるもの。
参照関係はD列に明示されている
結果
マクロ実行された結果。線の調整は行ってください。
