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