求救啊！！！！！！！！！1

2025-03-06 11:59:24

推荐回答（1个）

回答1：

这个代码有些地方需要改一下
1、 AcadDoc 改为 ThisDrawing ，你用查找替换（因为cad默认的文件名为ThisDrawing，作者改了文件名，所以不通用，但作者写的没错）
2、需要加一个代码
Sub a()
Call ChangeEntity(10, 1000, "p", True)
End Sub（因为作者写的是子程序，我们必须有一个主程序来调用他，其中p 为你要替换的块的名字，引号必须有，10，和1000 为被替代圆的最小和最大半径，在他们之间的圆才会被替代）
3、如何运行代码
首先，打开cad，点工具--宏--Visual Basic 编辑器，弹出窗体，点击菜单插入--模块--复制以下代码（我已经改好）
Sub a()
Call ChangeEntity(10, 1000, "p", True)
End Sub
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 = ThisDrawing.SelectionSets("BlockCount")

If Err.Number <> 0 Then
Err.Clear
Set ssetObj = ThisDrawing.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) = " 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 = ThisDrawing.ModelSpace.InsertBlock(InsertionPoint, BlockName, 1, 1, 1, 0)

ssobject.Delete
Set NewBlock = Nothing
Next

'删除数组
Erase fType: Erase fData

'刷新视图
'thisdrawing.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
最后，改半径和块的名称，例如你要替代的圆的半径范围为10到100，块的名称为qw ,在sub a() 中改为
Call ChangeEntity(10, 100, "qw", True)
4、运行程序
返回 cad 窗口，点击工具--宏--宏---弹出窗口---点击运行

最新问答

谁能帮我血好9上的化学高分

已知函数f(x)=sin(2x+三分之派)+sin(2x-三分之派)+2cos方x-1,求函数最小正周期

高考是必须要回户口所在地考试吗?

感觉心脏不太好嘴唇紫是什么原因每分

如图，在平面直角坐标系中，A（-3，0），B（0，4），现将线段AB向右平移8个单位得到线段DC（D与A对应，C

汇编问题，帮忙看看这个程序是用来1、干什么的，2、哪里有错？ again那里错误提示：out of memory 为什么

我的感情很容易受到伤害怎么办？

杭州地铁一共有多少个线路？

赛尔号用魔焰哈莫盖亚雷伊丽莎鲁斯王怎么打罗德利斯

大音希声，大象无形是什么意思