找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 1570|回复: 10

[LISP程序]:图层合并(对属性块内的属性也有效)

[复制链接]
发表于 2004-6-21 22:50:31 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有账号?立即注册

×
[php]
;;;;;Move all objects in the drawing to Layer "0" and delete the other
;;;;;layers. It doesn't work for XREF
(defun C:lay0 (/ old_cmdecho laylist)
  (setq old_cmdecho (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setvar "clayer" "0")
  (setq laylist (vl-remove "0" (GetLayerList)))
  (foreach lay laylist
    (MergeLayers lay "0")
  )
  (command "_.regenall")
  (setvar "CMDECHO" old_cmdecho)
  (princ)
)
;;;Get layer list
(defun GetLayerList (/ acadobject activedocument LayerTable thelist)
  (setq acadobject (vlax-get-Acad-Object))
  (setq activedocument (vla-get-activedocument acadobject))
  (setq LayerTable (vla-get-layers activedocument))
  (setq thelist '())
  (vlax-for each LayerTable
    (setq thelist (append (list (vla-get-Name each)) thelist))
  )
  (if thelist
    (reverse thelist)
  )
)

;;;;;下面的程序将图中图层lay1合并至图层lay2
;;;;;对属性块也有效
(defun MergeLayers (lay1 lay2 / cnt space blocks attrs)
  (command "-layer" "u" lay1 "")
  (setq        blocks (vla-get-blocks
                 (vla-get-activedocument (vlax-get-acad-object))
               )
  )
  (setq cnt 0)
  (while (< cnt (vla-get-count blocks))
    (setq space (vla-item blocks cnt))
    (vlax-for itm space
      (if (= (strcase (vla-get-layer itm)) (strcase lay1))
        (vla-put-layer itm lay2)
      )
      (if (and (= (vla-get-ObjectName itm) "AcDbBlockReference")
               (= (vla-get-HasAttributes itm) :vlax-true)
          )
        (progn
          (setq        attrs (vlax-safearray->list
                        (vlax-variant-value (vla-getattributes itm))
                      )
          )
          (foreach attr        attrs
            (if        (= (strcase (vla-get-layer attr)) (strcase lay1))
              (vla-put-layer attr lay2)
            )
          )
        )
      )
    )
    (setq cnt (1+ cnt))
  )
  (if (= (getvar "CLAYER") lay1)(setvar "CLAYER" lay2))
  (command "_.purge" "lay" lay1 "_n")
;;;  (command "_.regenall")
  (princ)
)

[/php]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 488个

财富等级: 日进斗金

发表于 2004-6-22 02:05:31 | 显示全部楼层
块定义里再来一下,就差不多了.
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 23个

财富等级: 恭喜发财

发表于 2004-6-22 13:06:53 | 显示全部楼层
这个程序的结构有些问题,请作者检查,修正浪费时间的代码.
另: 这个程序可能并不能"完全"实现作者的目的,应该还需要一些更多的工作,希望大家就此问题发表自己的看法.... 8-)
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2004-6-22 16:02:03 | 显示全部楼层
多谢两位斑竹指教。e2002说的对,我忙乱中把(command "_.purge"...)那一句放在循环里了,现已改正。至于程序是否“完全“能实现意图,我特意为此函数加了一个命令lay0,它的功能是把图中所有图层合并到0图层。我打开一张含有三四十个图层和一些图块和属性块。执行后剩下0和Defpoints,在执行一次就近剩下0图层,不知为何。可能是第一次PURGE的时候,有的图层是被参照着。当然,程序对xref是无效的。还希望两位斑竹继续指导。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 23个

财富等级: 恭喜发财

发表于 2004-6-22 16:31:11 | 显示全部楼层
还有...继续找...8-)

另: 考虑: 在各Layouts的PSpace中是否还有对象?,各DimensionStyle中的设置中是否还有指定的图层?....
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2004-6-22 19:05:15 | 显示全部楼层
最初由 e2002 发布
[B]还有...继续找...8-)

另: 考虑: 在各Layouts的PSpace中是否还有对象?,各DimensionStyle中的设置中是否还有指定的图层?.... [/B]


  (setq  blocks (vla-get-blocks
         (vla-get-activedocument (vlax-get-acad-object))
           )
这里得到的blocks里的前几个成员已包括了Layouts的Mspace和各个Pspace。它们是指向同样的东西。至于Dimstyles,没有考虑过,似乎没有图层的问题。请斑竹给我一个反例,也许会容易找到问题。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-8-4 18:38:10 | 显示全部楼层
借鉴下 谢谢了
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2017-3-26 21:43:04 | 显示全部楼层
谢谢分享........
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复

使用道具 举报

发表于 2017-3-26 21:44:48 | 显示全部楼层
命令无效,不知什么原因
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2018-7-15 21:09:28 | 显示全部楼层
谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢谢
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 1928个

财富等级: 堆金积玉

发表于 2018-7-16 18:17:26 | 显示全部楼层
(defun MergeLayers (lay1 lay2 / docment for-item blocks obj)
  (setq       
                docment        (vla-get-activedocument (vlax-get-acad-object))
                blocks        (vla-get-blocks docment)
                modelspace (vla-get-modelspace docment)
  )
        (vlax-for for-item modelspace
                (if (= (strcase (vla-get-layer for-item)) (strcase lay1))
                        (vla-put-layer for-item lay2)
                )
  )
  (vlax-for for-item blocks
    (vlax-for obj for-item
            (if (= (strcase (vla-get-layer obj)) (strcase lay1))
                                (vla-put-layer obj lay2)
                        )
    )
  )   
        (princ)
)
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

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

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-3-29 13:54 , Processed in 0.506573 second(s), 51 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表