[LISP程序]：几个常用层处理实用程序

ydf7332462

这几个命令能透明运行吗?

taner

參考這裏:http://www.mjtd.com/bbs/dispbbs. ... ID=39812&page=1

hyswljy

好

taner

[PHP];;;************************************************************
;;; Filename: LayerTools.LSP
;;; Author:   David M. Stein
;;; Date:     April 2002
;;; Purpose:  Demonstrates use of ActiveX access to AutoCAD
;;;           layer features through Visual LISP
;;;************************************************************

(vl-load-com)

;;; Set current layer to that of picked object

(defun C:SETLAY ( / adoc layers ent lay)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
        layers (vla-get-layers adoc)
  )
  (cond
    ( (setq ent (entsel "\nSelect object on layer to set active: "))
      (setq lay (vla-get-layer (vlax-ename->vla-object (car ent))))
      (vla-put-activelayer adoc (vla-item layers lay))
    )
  )
  (vlax-release-object layers)
  (vlax-release-object adoc)
  (princ)
)

;;; Copy layer assignment from one object to a selection set of objects

(defun C:COPYLAY ( / adoc ent lay sset i)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (cond
    ( (setq ent (entsel "\nSelect object on layer to copy from: "))
      (setq lay (vla-get-layer (vlax-ename->vla-object (car ent))))
      (princ (strcat "\nSelect objects to move to layer " lay "..."))
      (cond
        ( (setq sset (ssget))
          (setq i 0)
          (vla-StartUndoMark adoc)
          (repeat (sslength sset)
            (vla-put-layer (vlax-ename->vla-object (ssname sset i)) lay)
            (setq i (1+ i))
          )
          (vla-EndUndoMark adoc)
        )
      )
    )
  )
  (vlax-release-object adoc)
  (princ)
)

;;; Reset picked objects to use ByLayer color, linetype and lineweight

(defun C:BYLAYER ( / sset i obj adoc)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (princ "\nSelect objects to set ByLayer for color, linetype and lineweight...")
  (cond
    ( (setq sset (ssget))
      (setq i 0)
      (vla-StartUndoMark adoc)
      (repeat (sslength sset)
        (setq obj (vlax-ename->vla-object (ssname sset i)))
        (vla-put-color obj acByLayer)
        (vla-put-linetype obj "ByLayer")
        (vla-put-lineweight obj acLnWtByLwDefault)
        (setq i (1+ i))
      )
      (vlax-release-object obj)
      (vla-EndUndoMark adoc)
    )
  )
  (vlax-release-object adoc)
  (princ)
)

;;; Freeze layers of picked objects

(defun C:FREEZE ( / layers ent lay aclay adoc obj)
  (setq adoc   (vla-get-activedocument (vlax-get-acad-object))
        aclay  (vla-get-name (vla-get-activelayer adoc))
        layers (vla-get-layers adoc)
  )
  (while (setq ent (entsel "\nSelect object on layer to freeze: "))
    (setq obj (vlax-ename->vla-object (car ent))
          lay (vla-get-layer obj)
    )
    (if (/= (strcase lay) (strcase aclay))
      (progn
        (vla-put-freeze (vla-item layers lay) :vlax-true)
        (princ (strcat "\nFreezing layer: " lay))
      )
      (princ (strcat "\nCannot freeze the current layer: " aclay))
    )
  )
  (princ)
)

;;; Thaw and Turn ON all layers in current drawing

(defun C:THAW ( / adoc layers aclay)
  (setq adoc   (vla-get-activedocument (vlax-get-acad-object))
        layers (vla-get-layers adoc)
        aclay  (vla-get-name (vla-get-activelayer adoc))
  )
  (vla-StartUndoMark adoc)
  (vlax-for each layers
    (if (/= (strcase (vla-get-name each)) (strcase aclay))
      (progn
        (vla-put-freeze each 0)
        (vla-put-layeron each 1)
      )
    )
  )
        (vla-Regen adoc T)
  (vla-EndUndoMark adoc)
  (vlax-release-object adoc)
  (vlax-release-object layers)
  (princ)
)

;;; Delete all objects on the layer of a picked object

(defun C:DLAY
  ( / adoc ent obj lay sset i)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (while (setq ent (entsel "\nSelect object on layer to delete: "))
    (setq obj (vlax-ename->vla-object (car ent)))
    (setq lay (vla-get-layer obj))
    (cond
      ( (setq sset (ssget "x" (list (cons 8 lay))))
        (princ (strcat "\nDeleting " (itoa (sslength sset)) " objects on layer " lay))
        (vla-StartUndoMark adoc)
        (setq i 0)
        (repeat (sslength sset)
          (vla-delete (vlax-ename->vla-object (ssname sset i)))
          (setq i (1+ i))
        )
        (vla-EndUndoMark adoc)
      )
    )
    (vlax-release-object obj)
  ); while
  (vlax-release-object adoc)
  (princ)
)
(princ)[/PHP]

qiaqiadeng

看我的宝贝，我觉得开关图层比目前网上所有的都先进，本程序的亮点是ea命令选择对象是用ssget，而不是用entsel，可以同时保留1~n个图层，而不是目前网上流行的只能保留一个图层的。

taner

最初由 hqd9639 发布
[B][code];;;**************************************************************************
;;;1.删除某个层
(defun c:hqddellayer ()
  (vl-load-com)
  (setq acadObject (vlax-get-acad-object))
  (setq acad... [/B]

http://www.xdcad.net/forum/showt ... y=&pagenumber=3

h0404

复制了，看看。