图块替换。。。
请教，哪位大师能帮我写一个替换图块的VBA程序：我想把图纸中所有的图块A替换成图块B， 并把图块A删除，这两个图块的插入点相同。（图块我可以放在一个固定的目录下) 我想用选择集函数SSGET得到要替换A块的实体名，逐一获取A块的插入点，然后再从插入点表中逐一读取插入点插入B块，但是不知道获取插入点的VBA程序怎么写...
(defun C:reb ( / ss BlkName ents i)
(setvar "osmode" 0)
(princ "\n请选择作为源块的图块:")
(setq ss (ssget (list (cons 0 "INSERT"))))
(setq BlkName (cdr (assoc 2 (entget (ssname ss 0)))))
(princ "\n请选择将替换的图块:")
(setq ss (ssget (list (cons 0 "INSERT"))))
(if ss
(progn
(setq i 0)
(repeat (sslength ss)
(setq ents (entget (ssname ss i)))
(setq ents (subst (cons 2 BlkName) (assoc 2 ents) ents))
(entmod ents)
(setq i (1+ i))
)
)
)
(princ)
) 谢谢，但是我们现在项目用的是vba
我自己写了一段替换的程序，但总是执行不了，编译又没出现错误，请大侠们帮忙看看啊！
'清空选择集合中已有的选择集，避免重名
Dim ssetObjDelete As AcadSelectionSet
Dim ssetObjsCount As Integer
Dim ssetObj As AcadSelectionSet
If ThisDrawing.SelectionSets.Count0 Then
' MsgBox "选择集的个数为： " & ThisDrawing.SelectionSets.Count
For ssetObjsCount = ThisDrawing.SelectionSets.Count - 1 To 0 Step -1
On Error Resume Next
Set ssetObjDelete = ThisDrawing.SelectionSets.Item(ssetObjsCount)
If Err0 Then
Err.Clear
SignError = -1
MsgBox "系统未能整理出足够的资源，请再执行一遍程序" & Chr(13) & Chr(10) & _
"清除第" & ssetObjsCount + 1 & " 个选择集时出现问题", 48, "系统提示"
Exit Sub
End If
ssetObjDelete.Delete
Next
End If
'/////////////////////////////////////////////////////////////////////
Dim tmpSsetObjString As String
Dim tmpSsetObjCount As Integer
tmpSsetObjCount = 0
ssetObjCreate:
tmpSsetObjString = "a" & tmpSsetObjCount
'创建选择集,注意输出的选择集名
On Error Resume Next
Set ssetObj = ThisDrawing.SelectionSets.Add(tmpSsetObjString)
If Err0 Then
Err.Clear
'MsgBox "创建第" & tmpSsetObjCount & " 个选择集时出现问题"
tmpSsetObjCount = tmpSsetObjCount + 1
If tmpSsetObjCount = 10 Then
SignError = -1
MsgBox "系统资源紧张，要求重新启动 AutoCAD Map 或 AutoCAD 再进入", , "系统提示"
Exit Sub
End If
GoTo ssetObjCreate
End If
'///////////////////////////////////////////////////////////////////////
Dim tempEntity As AcadEntity
Dim lstblock As AcadBlocks '
Dim tempI As Integer
'把要被替换的图块（名为TK_CheckSign）加入到选择集中
Set lstblock = ThisDrawing.Blocks
If lstblock.Count = 0 Then
MsgBox "图形中没有对象"
Exit Sub
Else
For tempI = 0 To lstblock.Count - 1
Set tempEntity = lstblock.Item(tempI)
'获取签名标识块（）
If tempEntity.Name = "TK_CheckSign" Then
ssetObj.AddItems tempEntity
End If
Next
End If
'替换过程
Dim basePoint(0 To 2) As Double
Dim insertedBlock As AcadExternalReference
Dim objItem As AcadBlock
Dim PathName As String
PathName = "D:/AutoCAD 2002/Sample/Drawing2.dwg"
For Each objItem In ssetObj
' 获得块的插入点(不知道获得插入点的方法对不对)
basePoint(0) = objItem.InsertionPoint(0)
basePoint(1) = objItem.InsertionPoint(1)
basePoint(2) = objItem.InsertionPoint(2)
Set insertedBlock = ThisDrawing.paperSpace.AttachExternalReference(PathName, "XREF_IMAGE", basePoint, 1, 1, 1, 0, False)
Next objItem
我有个建议，不如把图纸中的A块定义换成B块的图形，这样不用去找图纸里的插入的块的位置，直接就全部替换了。
试验了一下，似乎没什么可操作性。当我什么都没说过吧。
VBA的局限性果然比较大啊！
不用在图中一个一个替换吧。获取图中块A的引用，清除块A中的图元，把块B中的图元赋给块A，图中所有的块A自然变成块B的内容了。
我没有实际做过，仅提供一点思路，个人感觉应该可行，起码不用一个一个的替，那样如果块很多的话会非常慢的。
个人意见，仅供参考。
呵呵，其实有个很简单的方法。
用选择集得到所有需要被替换的的图块A，
然后循环，把 图块A的名字直接改为图块B就可以了。
我写过一个程序就是专门做这个的。楼主可以直接用，也可以参考一下。
多谢各位的帮助，我下去再研究一下。。。
其实很简单，选择需要修改的“A”块，右键点击“在位编辑块”，点击“添加”，选择“B”块，放在“A”块同样的位置，删除“A”块，然后保存退出，即可，哪怕1000个“A”，转眼就替换为“B”块。非常便捷，呵呵。
或者单个替换程序见3楼所示，添加lsp文件以后，点击reb命令即可。
在下载栏目里，我以前传个程序，，块替换你搜下，，里边的源码你也可以参照一下
要求是图块A与图块B要同时存在于当前图中
页:
[1]