[求助]如何创建带属性的块？

arej

mccad

Public Sub BlockSample()

    On Error Resume Next
    Dim bbbObj As AcadBlock
    Set bbbObj = ThisDrawing.Blocks(3)
    bbbObj.Delete
   
    '在创建新块对象之前，Blocks中的块数量
    MsgBox "创建新块之前的块数量为：" & ThisDrawing.Blocks.Count
   
    '准备创建一个图块
    Dim blkObj As AcadBlock
    Dim insPnt(0 To 2) As Double
   
    '设定图块对象的原点坐标
    insPnt(0) = 0: insPnt(1) = 0: insPnt(2) = 0
    '在Blocks集合中创建名为TestBlock1的块对象
    Set blkObj = ThisDrawing.Blocks.Add(insPnt, "TestBlock1")
   
    MsgBox "创建新块之后的块数量为：" & ThisDrawing.Blocks.Count
   
'-------------------------------------------------------------
    '本段代码将在TestBlock1块对象中创建2个图元对象
   
    Dim cirObj As AcadCircle
    Dim center(0 To 2) As Double
    Dim radius As Double
   
    center(0) = 0: center(1) = 0: center(2) = 0
    radius = 38
   
    '创建一个圆对象
    Set cirObj = blkObj.AddCircle(center, radius)
    '将圆的颜色设为红色
    cirObj.Color = acRed
   
    Dim lineObj As AcadLine
    Dim sPnt(0 To 2) As Double, ePnt(0 To 2) As Double
   
    sPnt(0) = center(0): sPnt(1) = center(1): sPnt(2) = 0
    ePnt(0) = center(0) + 60: ePnt(1) = center(1) + 80: ePnt(2) = 0
   
    '创建一条直线
    Set lineObj = blkObj.AddLine(sPnt, ePnt)
   
'-------------------------------------------------------------
    '本段代码用来创建块属性
   
    Dim attObj As AcadAttribute
    Dim height As Double
    Dim tag As String
    Dim prompt As String
    Dim value As String
   
    '设定块属性在块空间中的位置
    insPnt(0) = -10: insPnt(1) = -10: insPnt(2) = 0
    '设定属性文字的高度
    height = 7
    '设定属性标签
    tag = "AttTag1"
    '设定属性提示值
    prompt = ""
    '设定属性值
    value = "AttValue1"
   
    '在块中创建属性对象
    Set attObj = blkObj.AddAttribute(height, acAttributeModePreset, _
                 prompt, insPnt, tag, value)
   
'-------------------------------------------------------------
    '本段代码将把TestBlock1块对象插入到模型空间
   
    Dim blkRefObj As AcadBlockReference
    Dim insertPnt(0 To 2) As Double
   
    '指定模型空间的插入点
    insertPnt(0) = 120: insertPnt(1) = 100: insertPnt(2) = 0
   
    '插入图块
    Set blkRefObj = ThisDrawing.ModelSpace.InsertBlock(insertPnt, _
                    "TestBlock1", 1#, 1#, 1#, 0#)
    blkRefObj.Update
    MsgBox ""
    ThisDrawing.Regen True
'-------------------------------------------------------------
    '本段代码让你选择是否将TestBlock1图块炸开
   
    Dim YesNo As Integer
   
    YesNo = MsgBox("你想将图块炸开吗？", vbYesNo)
    If YesNo = vbYes Then
        Dim entObjs As Variant
        Dim I As Integer
        
        '炸开块对象
        entObjs = blkRefObj.Explode
        '循环显示对象数组中的图元对象
        For I = 0 To UBound(entObjs)
            MsgBox "entObjs(" & I & ") = " & entObjs(I).ObjectName
        Next
        '删除原来的图块，只保留炸开的图元
        blkRefObj.Delete
    End If

End Sub