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

’把当前图纸中符合条件的圆替换为块(注：块在当前图纸中已存在)
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.Descri ption, vbCritical, "产生了以下错误:"
End Select
Err.Clear
End Sub