1、把当前图纸中符合条件的圆替换为块(注：块在当前图纸中已存在)Public Sub ChangeEntity(ByVal MinRadius As Double, ByVal MaxRadius As Double, _ByVal BlockName As Variant, ByVal AutoSelect As Boolean)On Error Resume NextDim ssobject As AcadCircleDim InsertionPoint(0 To 2) As DoubleDim NewBlock As AcadBlockReference创建选择集Dim ssetObj As
2、 AcadSelectionSetSet ssetObj = AcadDoc.SelectionSets(“BlockCount“)If Err.Number 0 ThenErr.ClearSet ssetObj = AcadDoc.SelectionSets.Add(“BlockCount“)End If清空选择集ssetObj.Clear创建过滤机制Dim fType(0 To 6) As IntegerDim fData(0 To 6) As VariantfType(0) = 0: fData(0) = “Circle“fType(1) = -4: fData(1) = “=“fTyp
3、e(3) = 40: fData(3) = MinRadiusfType(4) = -4: fData(4) = “选择符合条件的所有图元圆If AutoSelect Then自动选择方式ssetObj.Select acSelectionSetAll, , , fType, fDataElse提示用户选择ssetObj.SelectOnScreen fType, fDataEnd IfIf ssetObj.Count = 0 Then Exit Sub替换每一个圆为指定的块对象For Each ssobject In ssetObjInsertionPoint(0) = ssobject.C
4、enter(0)InsertionPoint(1) = ssobject.Center(1)InsertionPoint(2) = ssobject.Center(2)On Error GoTo ErrHandleSet NewBlock = AcadDoc.ModelSpace.InsertBlock(InsertionPoint, BlockName, 1, 1, 1, 0)ssobject.DeleteSet NewBlock = NothingNext删除数组Erase fType: Erase fData刷新视图AcadDoc.Regen acActiveViewportMsgBox
5、 “当前图纸中有 “ & ssetObj.Count & “ 个符合条件的圆被替换为块 “ & BlockName & “”。“, vbInformation, “提示:“删除选择集ssetObj.ClearssetObj.DeleteSet ssetObj = NothingExit SubErrHandle:Select Case Err.NumberCase -2147418113MsgBox “在当前图纸中找不到名称为: “ & BlockName & “” 的块参照, 请确认块名！“, vbCritical, “错误:“Case ElseMsgBox Err.Number & Chr(13) & Err.Description, vbCritical, “产生了以下错误:“End SelectErr.ClearEnd Sub
