ExcelDBShape2

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 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 = "T_" & varRng(j, 2) & "_" & CStr(i - j + 1) & ",L"
                    Exit Do
                End If
                j = j - 1
            Loop
            j = varRng(i, 5) + 1
            Do While j >= 2
                If varRng(j, 2) <> "" Then
                    tCn(UBound(tCn)).ToCn = "T_" & varRng(j, 2) & "_" & CStr(varRng(i, 5) - j + 2) & ",R"
                    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 = "T_" & varRng(j, 2) & "_" & CStr(i - j + 1) & ",R"
                    Exit Do
                End If
                j = j - 1
            Loop
            j = varRng(i, 6) + 1
            Do While j >= 2
                If varRng(j, 2) <> "" Then
                    tCn(UBound(tCn)).ToCn = "T_" & varRng(j, 2) & "_" & CStr(varRng(i, 6) - j + 2) & ",L"
                    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 Split(tCn(i).FromCn, ",")(1) = "L" Then
            shp.ConnectorFormat.BeginConnect shtOut.Shapes(Split(tCn(i).FromCn, ",")(0)), 2
        ElseIf Split(tCn(i).FromCn, ",")(1) = "R" Then
            shp.ConnectorFormat.BeginConnect shtOut.Shapes(Split(tCn(i).FromCn, ",")(0)), 4
        End If
        
        If Split(tCn(i).ToCn, ",")(1) = "L" Then
            shp.ConnectorFormat.EndConnect shtOut.Shapes(Split(tCn(i).ToCn, ",")(0)), 2
        ElseIf Split(tCn(i).ToCn, ",")(1) = "R" Then
            shp.ConnectorFormat.EndConnect shtOut.Shapes(Split(tCn(i).ToCn, ",")(0)), 4
        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 shpTrnd As Shape
    
    Dim shpOver As Shape
    Dim shpLine As Object
    Dim shpCn() As Object
    Dim shpRct() As Shape
    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
    Dim lngH As Single
    
    lngH = 20
    
    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, lngH * (UBound(tFld) - LBound(tFld) + 2))
    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, lngH * (UBound(tFld) - LBound(tFld) + 2))
    shpRound.Fill.ForeColor.RGB = RGB(255, 255, 255)
    shpRound.Adjustments.Item(1) = 0.05
    shpRound.Name = "R_" & tTable.Text
    shpRound.TextFrame2.TextRange.Font.Size = 8
    
    
    Set shpTrnd = sht.Shapes.AddShape(msoShapeRound2SameRectangle, tRect.Left, tRect.Top, tRect.Right - tRect.Left, lngH)
    shpTrnd.Adjustments.Item(1) = 0.1
    shpTrnd.Name = "TR_" & tTable.Text
    
    
    
    ReDim shpRct(UBound(tFld) + 1) As Shape
    
    Set shpRct(0) = sht.Shapes.AddShape(msoShapeRectangle, tRect.Left + 10, tRect.Top, tRect.Right - tRect.Left - 20, lngH)
    shpRct(0).TextFrame2.TextRange.Text = tTable.Text
    shpRct(0).Fill.Visible = msoFalse
    shpRct(0).Line.Visible = msoFalse
    shpRct(0).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    shpRct(0).Name = "T_" & tTable.Text & "_0"
    
    
    ReDim arrName(UBound(tFld) + 4) As String
    arrName(0) = shpOver.Name
    arrName(1) = shpRound.Name
    arrName(2) = shpTrnd.Name
    arrName(3) = shpRct(0).Name
    
    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
        
        Set shpRct(i + 1) = sht.Shapes.AddShape(msoShapeRectangle, tRect.Left + 10, tRect.Top + lngH * (i + 1), tRect.Right - tRect.Left - 20, lngH)
        shpRct(i + 1).TextFrame2.TextRange.Text = tFld(i).Text
        shpRct(i + 1).Fill.Visible = msoFalse
        shpRct(i + 1).Line.Visible = msoFalse
        shpRct(i + 1).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
        shpRct(i + 1).Name = "T_" & tTable.Text & "_" & CStr(i + 1)
        arrName(i + 4) = shpRct(i + 1).Name
    Next i
    
    shpTrnd.ZOrder msoSendToBack
    shpRound.ZOrder msoSendToBack
    shpOver.ZOrder msoBringToFront
    
    Set shpGrp = sht.Shapes.Range(arrName).Group
    shpGrp.Name = "G_" & tTable.Text
    Set CreateTable = shpGrp
    
End Function