Excel Word DBShape

VBA

Option Explicit


Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Sub Test()
    
    
    Dim shp As Word.Shape
    Dim tRect As RECT
    Dim strFields(3) As String
    
    strFields(0) = "商品A"
    strFields(1) = "商品B"
    strFields(2) = "商品C"
    strFields(3) = "商品D"
    
    tRect.Left = 100
    tRect.Top = 100
    tRect.Right = 200
    tRect.Bottom = 200
    
    Set shp = CreateTable("商品マスター", strFields, tRect)
    
    
End Sub


Function CreateTable(strTable As String, strFields() As String, tRect As RECT) As Word.Shape
    
    Dim objDoc As Document
    Dim shpRound As Word.Shape
    Dim shpLine As Word.Shape
    Dim strText As String
    Dim i As Long
    
    Set objDoc = New Document
    
    
    objDoc.Application.Visible = True
    Set shpRound = objDoc.Shapes.AddShape(msoShapeRoundedRectangle, tRect.Left, tRect.Top, tRect.Right - tRect.Left, tRect.Bottom - tRect.Top)
    
    Debug.Print TypeName(shpRound)
    
    
    shpRound.TextFrame.TextRange.Font.Size = 5
    strText = strTable
    For i = LBound(strFields) To UBound(strFields)
        strText = strText & vbCrLf & strFields(i)
    Next i
    
    shpRound.TextFrame.TextRange.Text = strText
    shpRound.TextFrame.VerticalAnchor = msoAnchorTop
    shpRound.TextFrame.MarginLeft = 0
    shpRound.TextFrame.MarginTop = 0
    shpRound.TextFrame.MarginRight = 0
    shpRound.TextFrame.MarginBottom = 0
    shpRound.TextFrame.AutoSize = msoAutoSizeShapeToFitText
    shpRound.Line.ForeColor.RGB = RGB(0, 0, 0)
    
    Set shpLine = objDoc.Shapes.AddLine(tRect.Left, tRect.Top + 20, tRect.Right, tRect.Top + 20)
    shpLine.Line.Weight = 1
    shpLine.Line.ForeColor.RGB = RGB(0, 0, 0)
    shpRound.ZOrder msoSendToBack
    
    Set CreateTable = objDoc.Shapes.Range(Array(shpRound.Name, shpLine.Name)).Group
    
    
End Function