'创建匿名块
Sub NiMingBlock1()
    On Error Resume Next
    If Err Then End
    Dim FilterSet As AcadSelectionSet
    Dim Blk As AcadBlock
    Dim E As AcadEntity
    Dim P As Variant
    Dim i As Integer
    Dim Obj() As Object

    Set FilterSet = ThisDrawing.SelectionSets.Add("XXX")
    If Err Then
        ThisDrawing.SelectionSets("XXX").Delete
        Set FilterSet = ThisDrawing.SelectionSets.Add("XXX")
        Err.Clear
    End If
    
    FilterSet.SelectOnScreen
    
    '将选择集中对象传递给Obj对象数组
    ReDim Obj(0 To FilterSet.Count - 1) As Object
    For i = 0 To FilterSet.Count - 1
        Set Obj(i) = FilterSet.item(i)
    Next i
    
    Dim Pmin As Variant, Pmax As Variant
    FilterSet.item(0).GetBoundingBox Pmin, Pmax

    Dim B_Name As String
    B_Name = NiMingKuai2("TC")
    Dim Temp As String
    '以文档创建时间后缀命名,(你可能同一时间创建两个块吗?,这样避免同名块,图和图之间不好复制)
    Temp = CStr(ThisDrawing.GetVariable("DATE"))
    B_Name = B_Name & "." & Temp
    '匿名块的插入点为第一个对象的角点
    Set Blk = ThisDrawing.Blocks.Add(Pmin, B_Name)

    ThisDrawing.CopyObjects Obj, Blk
    
    For Each E In FilterSet
        E.Delete
    Next
    
    ThisDrawing.ModelSpace.InsertBlock Pmin, Blk.Name, 1, 1, 1, 0
    
    '删除选择集
    ThisDrawing.SelectionSets.item("XXX").Delete
End Sub

'创建匿名块
Function NiMingKuai2(S As String) As String
    Dim blockObj As AcadBlock
    Dim N As Long
    NiMingKuai2 = S & "000"
Block:
    For Each blockObj In ThisDrawing.Blocks
        If Left(blockObj.Name, 5) = NiMingKuai2 Then '这里取5,是S的长度+3
            NiMingKuai2 = S & Format(N, "000")
            Prompt NiMingKuai2
            N = N + 1
            GoTo Block
        End If
    Next blockObj
End Function