マクロでER図の作成

### 要件
テーブル定義で主キーと外部キーがあれば、論理上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図作成」ボタンをクリックする

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/801991/bc2a632d-7ef5-fdad-5100-7bff07a0bb79.png)

#### 明細シート例

ちなみにこれもマクロで自動的に環境から取得されるもの。
参照関係はD列に明示されている
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/801991/7c529ce0-f13d-a0c5-2736-5135d6fc80ea.png)


### 結果
マクロ実行された結果。線の調整は行ってください。
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/801991/38ecd64d-ebc9-9a48-5e21-593aa87fa27a.png)