乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 128|回复: 9

图块替换。。。

[复制链接]

4

主题

12

帖子

2

银币

初来乍到

Rank: 1

铜币
28
发表于 2007-5-31 09:10:00 | 显示全部楼层 |阅读模式
请教,哪位大师能帮我写一个替换图块的VBA程序:我想把图纸中所有的图块A替换成图块B, 并把图块A删除,这两个图块的插入点相同。(图块我可以放在一个固定的目录下)
回复

使用道具 举报

4

主题

12

帖子

2

银币

初来乍到

Rank: 1

铜币
28
发表于 2007-5-31 10:16:00 | 显示全部楼层
我想用选择集函数SSGET得到要替换A块的实体名,逐一获取A块的插入点,
然后再从插入点表中逐一读取插入点插入B块,但是不知道获取插入点的VBA程序怎么写...
回复

使用道具 举报

91

主题

389

帖子

12

银币

中流砥柱

Rank: 25

铜币
763
发表于 2007-6-1 13:17:00 | 显示全部楼层
  1. (defun C:reb ( / ss BlkName ents i)
  2.    (setvar "osmode" 0)
  3.    (princ "\n请选择作为源块的图块:")
  4.    (setq ss (ssget (list (cons 0 "INSERT"))))
  5.    (setq BlkName (cdr (assoc 2 (entget (ssname ss 0)))))
  6.    (princ "\n请选择将替换的图块:")
  7.    (setq ss (ssget (list (cons 0 "INSERT"))))
  8.    (if ss
  9.      (progn
  10.        (setq i 0)
  11.        (repeat (sslength ss)
  12.   (setq ents (entget (ssname ss i)))
  13.   (setq ents (subst (cons 2 BlkName) (assoc 2 ents) ents))
  14.   (entmod ents)
  15.   (setq i (1+ i))
  16.        )
  17.      )
  18.    )
  19.    (princ)
  20. )
回复

使用道具 举报

4

主题

12

帖子

2

银币

初来乍到

Rank: 1

铜币
28
发表于 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
回复

使用道具 举报

3

主题

41

帖子

2

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
53
发表于 2007-6-1 17:01:00 | 显示全部楼层

我有个建议,不如把图纸中的A块定义换成B块的图形,这样不用去找图纸里的插入的块的位置,直接就全部替换了。
试验了一下,似乎没什么可操作性。当我什么都没说过吧。
VBA的局限性果然比较大啊!
回复

使用道具 举报

37

主题

151

帖子

1

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
299
发表于 2007-6-1 23:34:00 | 显示全部楼层
不用在图中一个一个替换吧。获取图中块A的引用,清除块A中的图元,把块B中的图元赋给块A,图中所有的块A自然变成块B的内容了。
我没有实际做过,仅提供一点思路,个人感觉应该可行,起码不用一个一个的替,那样如果块很多的话会非常慢的。
个人意见,仅供参考。
回复

使用道具 举报

26

主题

177

帖子

7

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
281
发表于 2007-6-3 13:02:00 | 显示全部楼层
呵呵,其实有个很简单的方法。
用选择集得到所有需要被替换的的图块A,
然后循环,把 图块A的名字直接改为图块B就可以了。
我写过一个程序就是专门做这个的。楼主可以直接用,也可以参考一下。

请点击此处下载

请先注册会员后在进行下载

已注册会员,请先登录后下载

文件名称:imerdkfhzar.dvb 
下载次数:0  文件大小:44.5 KB  售价:2银币 [记录]
下载权限: 不限 以上或 Vip会员   [开通Vip]   [签到领银币]  [免费赚银币]

回复

使用道具 举报

4

主题

12

帖子

2

银币

初来乍到

Rank: 1

铜币
28
发表于 2007-6-4 08:52:00 | 显示全部楼层
多谢各位的帮助,我下去再研究一下。。。
回复

使用道具 举报

0

主题

1

帖子

1

银币

初来乍到

Rank: 1

铜币
1
发表于 2009-11-12 20:23:00 | 显示全部楼层
其实很简单,选择需要修改的“A”块,右键点击“在位编辑块”,点击“添加”,选择“B”块,放在“A”块同样的位置,删除“A”块,然后保存退出,即可,哪怕1000个“A”,转眼就替换为“B”块。非常便捷,呵呵。
或者单个替换程序见3楼所示,添加lsp文件以后,点击reb命令即可。
回复

使用道具 举报

0

主题

46

帖子

4

银币

初来乍到

Rank: 1

铜币
46
发表于 2009-11-13 09:42:00 | 显示全部楼层
在下载栏目里,我以前传个程序,,块替换  你搜下,,里边的源码你也可以参照一下
要求是图块A与图块B要同时存在于当前图中
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-7-1 20:09 , Processed in 0.983366 second(s), 77 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表