把当前图纸中符合条件的圆替换为块

'把当前图纸中符合条件的圆替换为块(注：块在当前图纸中已存在)
Public Sub ChangeEntity(ByVal MinRadius As Double, ByVal MaxRadius As Double, _
                          ByVal BlockName As Variant, ByVal AutoSelect As Boolean)
    On Error Resume Next
   
    Dim ssobject As AcadCircle
    Dim InsertionPoint(0 To 2) As Double
    Dim NewBlock As AcadBlockReference
   
    '创建选择集
    Dim ssetObj As AcadSelectionSet
    Set ssetObj = AcadDoc.SelectionSets("BlockCount")
   
    If Err.Number <> 0 Then
        Err.Clear
        Set ssetObj = AcadDoc.SelectionSets.Add("BlockCount")
    End If
   
    '清空选择集
    ssetObj.Clear
   
    '创建过滤机制
    Dim fType(0 To 6) As Integer
    Dim fData(0 To 6) As Variant
   
    fType(0) = 0: fData(0) = "Circle"
   
    fType(1) = -4: fData(1) = "<AND"
    fType(2) = -4: fData(2) = ">="
    fType(3) = 40: fData(3) = MinRadius
    fType(4) = -4: fData(4) = "<="
    fType(5) = 40: fData(5) = MaxRadius
    fType(6) = -4: fData(6) = "AND>"

    '选择符合条件的所有图元－圆
    If AutoSelect Then
        '自动选择方式
        ssetObj.Select acSelectionSetAll, , , fType, fData
    Else
        '提示用户选择
        ssetObj.SelectOnScreen fType, fData
    End If
   
    If ssetObj.Count = 0 Then Exit Sub
   
    '替换每一个圆为指定的块对象
    For Each ssobject In ssetObj
        InsertionPoint(0) = ssobject.Center(0)
        InsertionPoint(1) = ssobject.Center(1)
        InsertionPoint(2) = ssobject.Center(2)
       
        On Error GoTo ErrHandle
       
        Set NewBlock = AcadDoc.ModelSpace.InsertBlock(InsertionPoint, BlockName, 1, 1, 1, 0)
       
        ssobject.Delete
        Set NewBlock = Nothing
    Next
   
    '删除数组
    Erase fType: Erase fData
   
    '刷新视图
    'AcadDoc.Regen acActiveViewport
   
    MsgBox "当前图纸中有 " & ssetObj.Count & " 个符合条件的圆被替换为块 “" & BlockName & "”。", vbInformation, "提示:"
   
    '删除选择集
    ssetObj.Clear
    ssetObj.Delete
   
    Set ssetObj = Nothing
    Exit Sub
ErrHandle:
    Select Case Err.Number
        Case -2147418113
            MsgBox "在当前图纸中找不到名称为: “" & BlockName & "” 的块参照,请确认块名！", vbCritical, "错误:"
        Case Else
            MsgBox Err.Number & Chr(13) & Err.Description, vbCritical, "产生了以下错误:"
    End Select
    Err.Clear
End Sub