图层控制---------减少图层

自贡黄明儒

;;减少图层时,力求不影响打印效果
;;用户只有一个选择[根据颜色/根据线型/根据线宽],因而操作容易
;;在明经泡了这么久,一直没有找到这样的工具.通过不断打坐和冥想,现在基本上写成现在的这个样子
;;有时,从设计院来的图,经过几个专业之后,图层有几百个之多,对于后来的处理实在麻烦,我一直想有减少图层的工具,在我的日志上贴出了一个不太成熟的东西
;;本程序是根据highflybird的改变块的颜色改编而来,在此对highflybird表示鸣谢!!!
;;对于颜色我是按索引号处理,虽然我不是色盲,对于颜色转换也不知怎么处理,尽管highflybird和C版都发表有相关程序
;;图中有尺寸时,Defpoints是删不掉的.
;;图层的删除我是用下面(HH:purge)命令删除的.有些软件生成的层(比如<钢构>),尽管图中没有它生成的任何对象,也删不掉图层,不知他们是怎么搞的

1. (defun HH:purge ()
   
2.     (vl-Catch-All-Apply
   
3.       '(lambda ()
   
4.   (vla-Remove
   
5.     (vla-GetExtensionDictionary
   
6.       (vla-Get-Layers
   
7.         (vla-Get-ActiveDocument (vlax-Get-Acad-Object))
   
8.       )
   
9.     )
   
10.     "ACAD_LAYERFILTERS"
    
11.   )
    
12.        )
    
13.     )
    
14.     (repeat 3
    
15.       (vla-purgeall
    
16. (vla-get-activedocument (vlax-get-acad-object))
    
17.       )
    
18.     )
    
19.   )
    
20. ;;下面的命令(DeleteLayer LayerName)删除图层好象也不太好使,不知哪位有没有更好的办法?
    
21. ;;删除图层
    
22.   (defun DeleteLayer (LayerName / AcadDocument LayerSel LayerObj)
    
23.     (setq AcadDocument (vla-get-activedocument (vlax-get-acad-object)))
    
24.     (setq LayerSel (vla-get-layers AcadDocument))
    
25.     (setq LayerObj (vl-catch-all-apply 'vla-item (list LayerSel LayerName)))
    
26.     (cond
    
27.       ((vl-catch-all-error-p LayerObj)
    
28.        (princ
    
29.   (strcat "\nError occurs when deleting Layer " LayerName "!")
    
30.        )
    
31.       )
    
32.       ((= (vla-get-name (vla-get-activelayer AcadDocument))
    
33.    LayerName
    
34.        )
    
35.        (princ (strcat "\nLayer " LayerName " is current layer!"))
    
36.       )
    
37.       (t (vla-delete LayerObj))
    
38.     )
    
39.   )
    

(defun HH:purge ()<br />     (vl-Catch-All-Apply<br />       '(lambda ()<br />   (vla-Remove<br />     (vla-GetExtensionDictionary<br />       (vla-Get-Layers<br />         (vla-Get-ActiveDocument (vlax-Get-Acad-Object))<br />       )<br />     )<br />     "ACAD_LAYERFILTERS"<br />   )<br />        )<br />     )<br />     (repeat 3<br />       (vla-purgeall<br /> (vla-get-activedocument (vlax-get-acad-object))<br />       )<br />     )<br />   )<br /> ;;下面的命令(DeleteLayer LayerName)删除图层好象也不太好使,不知哪位有没有更好的办法?<br /> ;;删除图层<br />   (defun DeleteLayer (LayerName / AcadDocument LayerSel LayerObj)<br />     (setq AcadDocument (vla-get-activedocument (vlax-get-acad-object)))<br />     (setq LayerSel (vla-get-layers AcadDocument))<br />     (setq LayerObj (vl-catch-all-apply 'vla-item (list LayerSel LayerName)))<br />     (cond<br />       ((vl-catch-all-error-p LayerObj)<br />        (princ<br />   (strcat "\nError occurs when deleting Layer " LayerName "!")<br />        )<br />       )<br />       ((= (vla-get-name (vla-get-activelayer AcadDocument))<br />    LayerName<br />        )<br />        (princ (strcat "\nLayer " LayerName " is current layer!"))<br />       )<br />       (t (vla-delete LayerObj))<br />     )<br />   )<br />

自贡黄明儒

;;;***********图层控制小工具 黄明儒 2012.8.15 命令:TC
;;ET把图层控制放在了首位,可见其重要性
;;本程序主要根据higflybird改变块而改写,同时参阅了C版、gu_xl等程序,在此不一一例举,并对他们表示感谢!!!
;;本程序根据我自己的需要而写,简洁的界面是我的习惯
;;在higflybird的符号管理器中,其实也包括了图层合并

自贡黄明儒

整合一下.部分代码
[hide=lisp]
  ;;1.1解锁所有图层
  (defun UnLock_All_Layers ()
    (vlax-for n (vla-get-layers
    (vla-get-ActiveDocument (vlax-get-acad-object))
  )
      (vla-put-lock n :vlax-false)
    )
  )
  ;;1.2锁所有图层
  (defun Lock_All_Layers ()
    (vlax-for n (vla-get-layers
    (vla-get-ActiveDocument (vlax-get-acad-object))
  )
      (vla-put-lock n :vlax-true)
    )
  )
  ;;2.1 解冻所有图层
  (defun UnFreeze_All_Layers ()
    (vlax-for n (vla-get-layers
    (vla-get-ActiveDocument (vlax-get-acad-object))
  )
      (if (/= (vla-get-name n) (getvar "clayer"))
;;也可以用 (not (equal (vla-get-activelayer adoc) item))判断
(vla-put-Freeze n :vlax-false)
      )
    )
  )
  ;;2.2 冻结所有图层
  (defun Freeze_All_Layers ()
    (vlax-for n (vla-get-layers
    (vla-get-ActiveDocument (vlax-get-acad-object))
  )
      (if (/= (vla-get-name n) (getvar "clayer"))
;;也可以用 (not (equal (vla-get-activelayer adoc) item))判断
(vla-put-Freeze n :vlax-true)
      )
    )
  )
  ;;3.1 开 所有图层
  (defun On_All_Layers ()
    (vlax-for n (vla-get-layers
    (vla-get-ActiveDocument (vlax-get-acad-object))
  )
      (vla-put-layeron n :vlax-true)
    )
  )
  ;;3.2 关 所有图层
  (defun Off_All_Layers ()
    (vlax-for n (vla-get-layers
    (vla-get-ActiveDocument (vlax-get-acad-object))
  )
      (vla-put-layeron n :vlax-false)
    )
  )
  ;;4.1 解冻 解锁 开 所有图层
  (defun UnLock_On_UnFreeze_All ()
    (vlax-for n (vla-get-layers
    (vla-get-ActiveDocument (vlax-get-acad-object))
  )
      (vla-put-lock n :vlax-false)
      (if (/= (vla-get-name n) (getvar "clayer"))
;;也可以用 (not (equal (vla-get-activelayer adoc) item))判断
(vla-put-Freeze n :vlax-false)
      )
      (vla-put-layeron n :vlax-true)
    )
    (vl-cmdf "regen")
  )
  ;;4.2 冻结 锁定 关所有图层
  (defun Lock_Off_Freeze_All ()
    (vlax-for n (vla-get-layers
    (vla-get-ActiveDocument (vlax-get-acad-object))
  )
      (vla-put-lock n :vlax-true)
      (if (/= (vla-get-name n) (getvar "clayer"))
;;也可以用 (not (equal (vla-get-activelayer adoc) item))判断
(vla-put-Freeze n :vlax-true)
      )
      (vla-put-layeron n :vlax-false)
    )
  )
  ;;5.1 解冻 解锁 开指定图层
  (defun UnLock_UnFreeze_On (strLayer / N)
    (setq n (vla-item (vla-get-layers
   (vla-get-activedocument
     (vlax-get-acad-object)
   )
        )
        strLayer
     )
    )
    (vla-put-lock n :vlax-false)
    (if (/= (vla-get-name n) (getvar "clayer"))
      ;;也可以用 (not (equal (vla-get-activelayer adoc) item))判断
      (vla-put-Freeze n :vlax-false)
    )
    (vla-put-layeron n :vlax-true)
  )
  ;;5.2 冻结 锁定 关指定图层
  (defun Lock_Freeze_Off (strLayer / N)
    (setq n (vla-item (vla-get-layers
   (vla-get-activedocument
     (vlax-get-acad-object)
   )
        )
        strLayer
     )
    )
    (vla-put-lock n :vlax-true)
    (if (/= (vla-get-name n) (getvar "clayer"))
      ;;也可以用 (not (equal (vla-get-activelayer adoc) item))判断
      (vla-put-Freeze n :vlax-true)
    )
    (vla-put-layeron n :vlax-false)
  )
  ;;6.1 开  实体所在图层
  (defun UnLock_UnFreeze_On_Objects (ss / N STRLAYER)
    (Lock_Off_Freeze_All)
    (repeat (setq n (sslength ss))
      (setq
strLayer (cdr (assoc 8 (entget (ssname ss (setq n (1- n))))))
      )
      (UnLock_UnFreeze_On strLayer)
    )
    (princ)
  )
  ;;6.2 关  实体所在图层
  (defun Lock_Freeze_Off_Objects (ss / N STRLAYER)
    (UnLock_On_UnFreeze_All)
    (repeat (setq n (sslength ss))
      (setq
strLayer (cdr (assoc 8 (entget (ssname ss (setq n (1- n))))))
      )
      (Lock_Freeze_Off strLayer)
    )
    (princ)
  )
[/hide]

669423907

Defpoints层 可以通过 CAD 的图层合并删除

linshiyin2

自带的清理可以自动删除无效图层，这个比较安全

smartstar

我来凑个热闹学习学习。

yaokui25

学习学习,借鉴借鉴  

tianyi1230

源码就好了，不过还是感谢

自贡黄明儒

tianyi1230 发表于 2012-8-16 22:58
源码就好了，不过还是感谢

如果需求的人多，源码放在100层

work0909_a77abc

感谢楼主共享，摇鼠标同仁敬上！