ExcelDBShape

VBA

Option Explicit
Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Public Type TAG_FIELD
    Text As String
    Font As Font
End Type
Public Type CONNECT
    FromCn As String
    ToCn As String
End Type
Sub test()
    
    PrintEntity ThisWorkbook.Worksheets("Sheet1"), ThisWorkbook.Worksheets("Sheet4")
    
End Sub
'No テーブル   フィールド 色 L R
'1  商品マスタ 商品A           6
'2             商品B         7
'3             商品C      *  9
'4             商品D      *    8
'5  店舗マスタ 店舗A
'6             店舗B
'7             店舗C
'8             店舗D      *
'9             店舗E
'10            店舗F      *
Sub PrintEntity(shtSrc As Worksheet, shtOut As Worksheet)
    
    Dim shp As Shape
    Dim tRect As RECT
    Dim strTable As String
    Dim tTable As TAG_FIELD
    
    Dim strFields() As String
    Dim lngNum() As Long
    Dim tFld() As TAG_FIELD
    Dim tCn() As CONNECT
    
    Dim i As Long
    Dim j As Long
    Dim varRng As Variant
    
    Dim strOld As String
    Dim lngOld As Long
    Dim fnt As Font
    
    tRect.Left = 100
    tRect.Top = 100
    tRect.Right = 200
    tRect.Bottom = 200
    
    varRng = shtSrc.UsedRange
    For i = LBound(varRng, 1) + 1 To UBound(varRng, 1)
        If varRng(i, 2) <> "" Then
            If strOld <> "" Then
                tTable.Text = strOld
                ReDim tFld(i - lngOld - 1) As TAG_FIELD
                For j = 0 To i - lngOld - 1
                    tFld(j).Text = varRng(j + lngOld, 3)
                    If varRng(j + lngOld, 4) = "*" Then
                        Set fnt = shtSrc.Cells(1, 1).Font
                        fnt.Color = RGB(255, 0, 0)
                        fnt.Name = "ＭＳ ゴシック"
                        fnt.Size = 8
                        Set tFld(j).Font = fnt
                    End If
                Next j
                Set shp = CreateTable(shtOut, tTable, tFld, tRect)
                tRect.Left = tRect.Left + 300
                tRect.Top = tRect.Top + 300
                tRect.Right = tRect.Right + 300
                tRect.Bottom = tRect.Bottom + 300
            End If
            strOld = varRng(i, 2)
            lngOld = i
        End If
        
        'コネクタの接続先の組み
        If varRng(i, 5) <> "" Then
            If Sgn(tCn) = 0 Then
                ReDim tCn(0) As CONNECT
            Else
                ReDim Preserve tCn(UBound(tCn) + 1) As CONNECT
            End If
            j = i
            Do While j >= 2
                If varRng(j, 2) <> "" Then
                    tCn(UBound(tCn)).FromCn = "C_L_" & varRng(j, 2) & "_" & CStr(i - j)
                    Exit Do
                End If
                j = j - 1
            Loop
            j = varRng(i, 5)
            Do While j >= 2
                If varRng(j, 2) <> "" Then
                    tCn(UBound(tCn)).ToCn = "C_L_" & varRng(j, 2) & "_" & CStr(varRng(i, 5) - j + 1)
                    Exit Do
                End If
                j = j - 1
            Loop
        End If
        If varRng(i, 6) <> "" Then
            If Sgn(tCn) = 0 Then
                ReDim tCn(0) As CONNECT
            Else
                ReDim Preserve tCn(UBound(tCn) + 1) As CONNECT
            End If
            j = i
            Do While j >= 2
                If varRng(j, 2) <> "" Then
                    tCn(UBound(tCn)).FromCn = "C_R_" & varRng(j, 2) & "_" & CStr(i - j)
                    Exit Do
                End If
                j = j - 1
            Loop
            j = varRng(i, 6)
            Do While j >= 2
                If varRng(j, 2) <> "" Then
                    tCn(UBound(tCn)).ToCn = "C_R_" & varRng(j, 2) & "_" & CStr(varRng(i, 6) - j + 1)
                    Exit Do
                End If
                j = j - 1
            Loop
        End If
    Next i
    tTable.Text = strOld
    ReDim tFld(i - lngOld - 1) As TAG_FIELD
    For j = 0 To i - lngOld - 1
        tFld(j).Text = varRng(j + lngOld, 3)
        If varRng(j + lngOld, 4) = "*" Then
            Set fnt = shtSrc.Cells(1, 1).Font
            fnt.Color = RGB(255, 0, 0)
            fnt.Name = "ＭＳ ゴシック"
            fnt.Size = 8
            
            Set tFld(j).Font = fnt
        End If
    Next j
    Set shp = CreateTable(shtOut, tTable, tFld, tRect)
    For i = 0 To UBound(tCn)
        Set shp = shtOut.Shapes.AddConnector(msoConnectorElbow, 1, 1, 2, 2)
        shp.Line.ForeColor.RGB = RGB(0, 0, 0)
        shp.Line.Weight = 2
        
        If Left(shtOut.Shapes(tCn(i).FromCn).Name, 4) = "C_L_" Then
            shp.ConnectorFormat.BeginConnect shtOut.Shapes(tCn(i).FromCn), 3
        ElseIf Left(shtOut.Shapes(tCn(i).FromCn).Name, 4) = "C_R_" Then
            shp.ConnectorFormat.BeginConnect shtOut.Shapes(tCn(i).FromCn), 7
        End If
        If Left(shtOut.Shapes(tCn(i).ToCn).Name, 4) = "C_L_" Then
            shp.ConnectorFormat.EndConnect shtOut.Shapes(tCn(i).ToCn), 3
        ElseIf Left(shtOut.Shapes(tCn(i).ToCn).Name, 4) = "C_R_" Then
            shp.ConnectorFormat.EndConnect shtOut.Shapes(tCn(i).ToCn), 7
        End If
    Next i
    
End Sub
Function CreateTable(sht As Worksheet, tTable As TAG_FIELD, tFld() As TAG_FIELD, tRect As RECT) As Object
    
    Dim shpGrp As Shape
    Dim shp As Shape
    Dim shpRound As Shape
    Dim shpOver As Shape
    Dim shpLine As Object
    Dim shpCn() As Object
    Dim lngSt() As Long
    Dim lngEd() As Long
    Dim blExist As Boolean
    Dim strText As String
    Dim i As Long
    Dim j As Long
    Dim arrName() As String
    
    ReDim lngSt(LBound(tFld) To UBound(tFld)) As Long
    ReDim lngEd(LBound(tFld) To UBound(tFld)) As Long
    Set shpOver = sht.Shapes.AddShape(msoShapeRoundedRectangle, tRect.Left, tRect.Top, tRect.Right - tRect.Left, 16 * (UBound(tFld) - LBound(tFld) + 2) + 15)
    shpOver.Name = "O_" & tTable.Text
    shpOver.Adjustments.Item(1) = 0.05
    shpOver.Fill.Transparency = 1
    shpOver.Line.Transparency = 1
    
    Set shpRound = sht.Shapes.AddShape(msoShapeRoundedRectangle, tRect.Left, tRect.Top, tRect.Right - tRect.Left, 16 * (UBound(tFld) - LBound(tFld) + 2) + 15)
    shpRound.Adjustments.Item(1) = 0.05
    shpRound.Name = "R_" & tTable.Text
    shpRound.TextFrame2.TextRange.Font.Size = 8
    strText = tTable.Text
    For i = LBound(tFld) To UBound(tFld)
        lngSt(i) = Len(strText) + 1
        lngEd(i) = Len(tFld(i).Text) + 1
        strText = strText & vbLf & tFld(i).Text
    Next i
    
    shpRound.TextFrame2.TextRange.Text = strText
    shpRound.TextFrame2.VerticalAnchor = msoAnchorTop
    shpRound.TextFrame2.MarginLeft = 0
    shpRound.TextFrame2.MarginTop = 0
    shpRound.TextFrame2.MarginRight = 0
    shpRound.TextFrame2.MarginBottom = 0
    For j = LBound(lngSt) To UBound(lngSt)
        If Not tFld(j).Font Is Nothing Then
            shpRound.TextFrame2.TextRange.Characters(lngSt(j), lngEd(j)).Font.Fill.ForeColor.RGB = tFld(j).Font.Color
        End If
    Next j
    shpRound.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    shpRound.TextFrame2.TextRange.ParagraphFormat.SpaceWithin = 1.5
    shpRound.Line.ForeColor.RGB = RGB(0, 0, 0)
    
    Set shpLine = sht.Shapes.AddLine(tRect.Left, tRect.Top + 18, tRect.Right, tRect.Top + 18)
    shpLine.Name = "L_" & tTable.Text
    
    shpLine.Line.Weight = 1
    shpLine.Line.ForeColor.RGB = RGB(0, 0, 0)
    shpRound.ZOrder msoSendToBack
    
    ReDim arrName(2) As String
    arrName(0) = shpOver.Name
    arrName(1) = shpRound.Name
    arrName(2) = shpLine.Name
    
    ReDim shpCn(2 * (UBound(tFld) - LBound(tFld) + 3)) As Object
    
    For i = LBound(tFld) - 1 To UBound(tFld)
        Set shpCn(i * 2 + 2) = sht.Shapes.AddShape(msoShapeFlowchartConnector, tRect.Left + 10, tRect.Top + 22 + i * 16, 5, 5)
        shpCn(i * 2 + 2).Name = "C_L_" & tTable.Text & "_" & CStr(i)
        shpCn(i * 2 + 2).Line.Visible = msoTrue
        shpCn(i * 2 + 2).Fill.Visible = msoTrue
        shpCn(i * 2 + 2).ZOrder msoBringToFront
        Set shpCn(i * 2 + 3) = sht.Shapes.AddShape(msoShapeFlowchartConnector, tRect.Right - 10, tRect.Top + 22 + i * 16, 5, 5)
        shpCn(i * 2 + 3).Name = "C_R_" & tTable.Text & "_" & CStr(i)
        shpCn(i * 2 + 3).Line.Visible = msoTrue
        shpCn(i * 2 + 3).Fill.Visible = msoTrue
        shpCn(i * 2 + 3).ZOrder msoBringToFront
        ReDim Preserve arrName(UBound(arrName) + 2) As String
        arrName(UBound(arrName) - 1) = shpCn(i * 2 + 2).Name
        arrName(UBound(arrName)) = shpCn(i * 2 + 3).Name
    Next i
    'shpOver.ZOrder msoBringToFront
    Set shpGrp = sht.Shapes.Range(arrName).Group
    shpGrp.Name = "G_" & tTable.Text
    Set CreateTable = shpGrp
    
    'Set CreateTable = sht.Shapes.Range(arrName).Group
    
    
End Function