图块替换。。。

Apple1122 · 发表于 2007-5-31 09:10:00

请教，哪位大师能帮我写一个替换图块的VBA程序：我想把图纸中所有的图块A替换成图块B，并把图块A删除，这两个图块的插入点相同。（图块我可以放在一个固定的目录下)

Apple1122 · 发表于 2007-5-31 10:16:00

我想用选择集函数SSGET得到要替换A块的实体名，逐一获取A块的插入点，
然后再从插入点表中逐一读取插入点插入B块，但是不知道获取插入点的VBA程序怎么写...

jaminth · 发表于 2007-6-1 13:17:00

(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)
)

Apple1122 · 发表于 2007-6-1 16:21:00

谢谢，但是我们现在项目用的是vba

我自己写了一段替换的程序，但总是执行不了，编译又没出现错误，请大侠们帮忙看看啊！

'清空选择集合中已有的选择集，避免重名
Dim ssetObjDelete As AcadSelectionSet
Dim ssetObjsCount As Integer
Dim ssetObj As AcadSelectionSet

If ThisDrawing.SelectionSets.Count <> 0 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 Err <> 0 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 Err <> 0 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

烟雨.江南 · 发表于 2007-6-1 17:01:00

本帖最后由作者于 2007-6-1 17:34:58 编辑

我有个建议，不如把图纸中的A块定义换成B块的图形，这样不用去找图纸里的插入的块的位置，直接就全部替换了。

试验了一下，似乎没什么可操作性。当我什么都没说过吧。

VBA的局限性果然比较大啊！

StartMe · 发表于 2007-6-1 23:34:00

不用在图中一个一个替换吧。获取图中块A的引用，清除块A中的图元，把块B中的图元赋给块A，图中所有的块A自然变成块B的内容了。

我没有实际做过，仅提供一点思路，个人感觉应该可行，起码不用一个一个的替，那样如果块很多的话会非常慢的。

个人意见，仅供参考。

subtlation · 发表于 2007-6-3 13:02:00

呵呵，其实有个很简单的方法。

用选择集得到所有需要被替换的的图块A，

然后循环，把图块A的名字直接改为图块B就可以了。

我写过一个程序就是专门做这个的。楼主可以直接用，也可以参考一下。

Apple1122 · 发表于 2007-6-4 08:52:00

多谢各位的帮助，我下去再研究一下。。。

hj7926691 · 发表于 2009-11-12 20:23:00

其实很简单，选择需要修改的“A”块，右键点击“在位编辑块”，点击“添加”，选择“B”块，放在“A”块同样的位置，删除“A”块，然后保存退出，即可，哪怕1000个“A”，转眼就替换为“B”块。非常便捷，呵呵。

或者单个替换程序见3楼所示，添加lsp文件以后，点击reb命令即可。

gdzhou · 发表于 2009-11-13 09:42:00

在下载栏目里，我以前传个程序，，块替换你搜下，，里边的源码你也可以参照一下

要求是图块A与图块B要同时存在于当前图中

账号		自动登录	找回密码
密码			注册

图块替换。。。

本帖子中包含更多资源