[その他]MK-2からコピーしたスキーマ情報からER図用のエンティティオブジェクトを作成するマクロ

Sub MR2ERtoExcelER()

 
    MsgBox "※変換したい情報を全部選択しておく必要があります※"

    Dim WB As Workbook
    Set WB = ActiveWorkbook
    Dim WS1 As Worksheet
    Set WS1 = WB.ActiveSheet
 
    '--------------------------------------------------------
    '実行速度向上のため画面更新と自動計算を停止
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    '-----------------------------------------------------------

    '現在選択しているセルの取得
    Dim intStartGyo As Integer: intStartGyo = Selection.Row
    Dim intLastGyo As Integer: intLastGyo = Selection.Row + Selection.Rows.Count - 1
    Dim intStartClm As Integer: intStartClm = Selection.Column
    Dim intLastClm As Integer: intLastClm = Selection.Column + Selection.Columns.Count - 1
 
    '※初期置
    Dim Rng As Range
    Set Rng = WS1.Cells(intStartGyo, intStartClm)
 
 
    Dim lWidth As Long: lWidth = 150  'エンティティオブジェクトのサイズ
    Dim lHeight  As Long: lHeight = 14  'エンティティオブジェクトのサイズ

    lLeft = Rng.Left + 350 '初期位置
    Ltop = Rng.Top + 10 '初期位置
 
    Dim TblCnt As Integer: TblCnt = 0
    Dim TblTitle As String
    Dim TblStartTop As Integer
    Dim ECnt As Integer
    Dim strShapes As String
    Dim FlgKey As Boolean
 
    For j = intStartGyo To intLastGyo
               
            'テーブルカウント
            If WS1.Cells(j, intStartClm).Text = "[Entity]" Then
                TblCnt = TblCnt + 1
                TblTitle = Replace(WS1.Cells(j + 1, intStartClm).Text, "PName=", "")
                ECnt = 0
                strShapes = ""
                Ltop = WS1.Cells(j + 1, intStartClm).Top + 10
                TblStartTop = Ltop
                FlgKey = True
            End If
                                           
            'エンティティの作成---------------------------------------
            If Left(WS1.Cells(j, intStartClm).Text, 6) = "Field=" Then
         
              Dim myShape1 As Shape
              Dim strText() As String
              strText = Split(WS1.Cells(j, intStartClm).Text, ",")
           
           
                '主キーからそうでなくなった場合、線を足す
                If strText(4) = "" Then
                    If FlgKey = True Then
                        Dim SShape As Shape
                        Set SShape = WS1.Shapes.AddConnector(msoConnectorStraight, lLeft, Ltop, lLeft + lWidth, Ltop)
                        strShapes = strShapes & "," & SShape.Name
                        FlgKey = False
                    End If
                End If
           
           
              Dim oShape As Shape
              Set oShape = WS1.Shapes.AddShape(msoShapeRectangle, lLeft, Ltop, lWidth, lHeight)
              With oShape
                .Fill.Visible = msoFalse
                .Fill.Solid 'グラデーション等無し
                .Line.Visible = msoFalse
                .TextFrame.Characters.Font.Color = vbBlack
                If strText(4) = "" Then
                    .TextFrame.Characters.Text = Replace(strText(1), """", "")
                Else
                    .TextFrame.Characters.Text = "■" & Replace(strText(1), """", "")
                End If
                .TextFrame.Characters.Font.Size = 8
                .TextFrame.HorizontalAlignment = xlHAlignLeft
              End With
              strShapes = strShapes & "," & oShape.Name
           
           
              '追加位置を下へずらす
              Ltop = Ltop + lHeight
              ECnt = ECnt + 1
            End If
            '-------------------------------------------------------
               
            '次が異なるテーブルor終了行---------------------------------
            If Len(strShapes) > 0 Then
            If WS1.Cells(j + 1, intStartClm).Text = "[Entity]" Or j + 1 = intLastGyo Then
           
               
              Set oShape = WS1.Shapes.AddShape(msoShapeRectangle, lLeft, TblStartTop - 20, lWidth, 30 + ECnt * (lHeight + 1))
              With oShape
                .Fill.Visible = msoFalse
                .Fill.Solid 'グラデーション等無し
                .Line.Visible = msoTrue
                .TextFrame.Characters.Font.Color = vbBlue
                .TextFrame.Characters.Text = TblTitle
                .TextFrame.Characters.Font.Size = 8
                .TextFrame.HorizontalAlignment = xlHAlignLeft
              End With
              'strShapes(ECnt) = oShape.Name
              'ActiveSheet.Shapes.Range(Array("""" & oShape.Name & """" & strShapes)).Select
              strShapes = strShapes & "," & oShape.Name
           
           
              Dim valShapes() As String
              valShapes = Split(strShapes, ",")
         
           
              'oShape.Select
              'Selection.ShapeRange.Group.Select
              WS1.Shapes.Range(valShapes).Group
               
                 '追加位置を右へずらす
                'lLeft = lLeft + lWidth + 5
                '追加位置を下へずらす
                Ltop = Ltop + 30 + ECnt * (lHeight + 1) + 10
         
            End If
            End If
            '------------------------------------------------------------
 
    Next

    '実行速度向上のため画面更新と自動計算を再開---------------
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    '-----------------------------------------------------------


End Sub