VB编程操作AutoCAD块对象（转载）

以下文字来自于 weixin_34183910的博客https://blog.csdn.net/weixin_34183910/article/details/85489135

块对象指Blocks集合对象和Block对象，Blocks对象包含一个图形文档中的所有命名的图块，Block对象则包含构成一个图块的所有实体对象，块对象的创建与引用包含3个步骤：用块对象的Add方法创建一个命名块，向块对象添加实体，用InsertBlock方法将该块插入到任何地方，即引用块。

下面的代码创建一个块对象，并向块中添加一个圆，然后在不同位置插入该块对象。

Private Sub Command1_Click() 
    Dim blockobj As AcadBlock 
    Dim insertionpnt(0 To 2) As Double 
    insertionpnt(0) = 0#: insertionpnt(1) = 0#: insertionpnt(2) = 0# 
    Set blockojb = acadapp.ActiveDocument.Blocks.Add(insertionpnt, "circleblock") 
    Dim circleobj As AcadCircle 
    Dim center(0 To 2) As Double 
    Dim radius As Double 
    center(0) = 0: center(1) = 0: center(2) = 0 
    radius = 1 
    Set circleobj = blockobj.AddCircle(center, radius) 
    Dim blockrefobj As AcadBlockReference 
    Set blockrefobj = acadapp.ActiveDocument.ModelSpace.InsertBlock(insertionpnt, "circleblock", 1#, 1#, 1#, 0) 
    insertionpnt(0) = 5#: insertionpnt(1) = 2#: insertionpnt(2) = 0 
    Set blockrefobj = acadapp.ActiveDocument.ModelSpace.InsertBlock(insertionpnt, "Circleblock", 1#, 1#, 1#, 0) 
    ZoomExtents 
End Sub

当实体对象行程块，插入文档形成块引用时，可以用Explode方法将其炸开，重新获得单独的实体对象，然后就可以对块对象进行修改，或者添加、删除组成的实体对象。下面的代码创建一个块对象，想块中添加两个同心圆，将块对象插入文档形成引用对象，然后炸开块，改变两个同心圆的颜色，再删除块引用和第一个圆。

Private Sub Command1_Click() 
    Dim blockobj As AcadBlock 
    Dim insertionpnt(0 To 2) As Double 
    insertionpnt(0) = 0 
    insertionpnt(1) = 0 
    insertionpnt(2) = 0 
    Set blockobj = acadapp.ActiveDocument.Blocks.Add(insertionpnt, "circleblock") 
    Dim circleobj1 As AcadCircle 
    Dim circleobj2 As AcadCircle 
    Dim center(0 To 2) As Double 
    center(0) = 0 
    center(1) = 0 
    center(2) = 0 
    Set circleobj1 = blockobj.AddCircle(center, 1) 
    Set circleobj2 = blockobj.AddCircle(center, 3) 
    Dim blockrefobj As AcadBlockReference 
    insertionpnt(0) = 2 
    insertionpnt(1) = 2 
    insertionpnt(2) = 0 
    Set blockrefobj = acadapp.ActiveDocument.ModelSpace.InsertBlock(insertionpnt, "circleblock", 1#, 1#, 1#, 0) 
    ZoomExtents 
    MsgBox "图形" 
    Dim explodedobjects As Variant //仅获取分解对象，不删除原参照
    explodedobjects = blockrefobj.Explode 
    Dim i As Integer 
    For i = 0 To UBound(explodedobjects) 
        MsgBox "炸开" 
        explodedobjects(i).Color = acRed 
        explodedobjects(i).Update 
    Next 
    blockrefobj.Delete 
    explodedobjects(0).Delete //最好删除分解对象
End Sub

用AddAttribute方法可以创建块属性对象，块的属性可以给块添加文字，用来显示块的相关信息，将带有属性的块插入文档，创建一个块引用对象，可以从该块引用中提取并修改块属性信息，下面的代码创建一个块对象，向块对象中添加一个圆，然后创建块属性对象，再插入块，创建块引用对象，提取该对象引用属性并在消息框中显示属性标记，然后修改块属性，再次提取块引用属性并再消息框中显示属性标记和属性值。

Private Sub Command1_Click() 
    Dim blockobj As AcadBlock 
    Dim insertionpnt(0 To 2) As Double 
    insertionpnt(0) = 0 
    insertionpnt(1) = 0 
    insertionpnt(2) = 0 
    Set blockobj = acadapp.ActiveDocument.Blocks.Add(insertionpnt, "testblock") 
    Dim circleobj As AcadCircle 
    Dim center(0 To 2) As Double 
    Dim radius As Double 
    center(0) = 0: center(1) = 0: center(2) = 0 
    radius = 5 
    Set circleobj = blockobj.AddCircle(center, radius) 
    Dim attributeobj As AcadAttribute 
    Dim height As Double 
    Dim mode As Long 
    Dim prompt As String 
    Dim insertionpoint(0 To 2) As Double 
    Dim tag As String 
    Dim value As String 
    height = 1# 
    mode = acAttributeModeVerify 
    prompt = "attribute prompt" 
    insertionpoint(0) = 1 
    insertionpoint(1) = 1 
    insertionpoint(2) = 0 
    tag = "attribute tag" 
    value = "attribute value" 
    Set attributeobj = blockobj.AddAttribute(height, mode, prompt, insertionpoint, tag, value) 
    Dim blockrefobj As AcadBlockReference 
    insertionpnt(0) = 2 
    insertionpnt(1) = 2 
    insertionpnt(2) = 0 
    Set blockrefobj = acadapp.ActiveDocument.ModelSpace.InsertBlock(insertionpnt, "testblock", 1, 1, 1, 0) 
    ZoomExtents 
    Dim varattributes As Variant 
    varattributes = blockrefobj.GetAttributes 
    Dim strattributes As String 
    strattributes = "" 
    Dim i As Integer 
    For i = LBound(varattributes) To UBound(varattributes) 
        strattributes = strattributes + "tag:" + varattributes(i).TagString + vbCrLf + "value:" + varattributes(i).TextString 
    Next 
    MsgBox "引用" 
    varattributes(0).TextString = "NEW VALUE" 
    varattributes(0).Update 
    Dim newvarattributes As Variant 
    newvarattributes = blockrefobj.GetAttributes 
    strattributes = "" 
    For i = LBound(varattributes) To UBound(varattributes) 
        strattributes = strattributes + "Tag:" + newvarattributes(i).TagString + vbCrLf + "value:" + newvarattributes(i).TextString 
    Next 
    MsgBox "块引用:" 
End Sub