AutoCAD VBA组块

Sub CreateBlockFromEntities()
    Dim blockName As String
    Dim basePoint As Variant
    Dim selectedEntities As AcadSelectionSet
    Dim blockDef As AcadBlock
    Dim blockRef As AcadBlockReference
    
    ' 设置图块名称
    blockName = "MyBlock"
    
    ' 设置图块的基点
    basePoint = ThisDrawing.Utility.GetPoint(, "请选择图块的基点: ")
    
    ' 创建选择集
    On Error Resume Next
    ThisDrawing.SelectionSets("MySelectionSet").Delete
    On Error GoTo 0
    Set selectedEntities = ThisDrawing.SelectionSets.Add("MySelectionSet")
    
    VBA.AppActivate Application.Caption
    ' 提示用户选择图元
    selectedEntities.SelectOnScreen
    
    ' 检查是否有图元被选中
    If selectedEntities.Count = 0 Then
        MsgBox "没有选择任何图元。"
        Exit Sub
    End If
    
    Dim ents() As AcadEntity, i As Long
    ReDim ents(selectedEntities.Count - 1)
    For i = 0 To selectedEntities.Count - 1
        Set ents(i) = selectedEntities.Item(i)
    Next
    
    ' 创建图块定义
    Set blockDef = ThisDrawing.Blocks.Add(basePoint, blockName)
    
    ' 将选中的图元添加到图块定义中
    ThisDrawing.CopyObjects ents, blockDef
    
    ' 插入图块
    Set blockRef = ThisDrawing.ModelSpace.InsertBlock(basePoint, blockName, 1#, 1#, 1#, 0)
    
    ' 清理选择集
    selectedEntities.Delete
    
    ' 刷新视图
    ThisDrawing.Regen acAllViewports
    
    MsgBox "图块创建并插入成功！"
End Sub