几个有用的CAD的加载程序LISP (2013-01-10 18:58:27)转载▼

标签： cad加载程序 杂谈 分类： CAD应用

1.图层命令

;;; -----------------------------------------------------------------

;;; 2 图层命令

;;; ------------------------------------------------------------------

;;;  2.1 LayerOff 关闭物体所在的层（单选）

(defun c:1 (/ ent lname)

 (setvar "cmdecho" 0)

 (setq ent (entsel "\nPick an entity on the target layer: "))

 (if ent

  (progn

   (setq ent (entget (car ent)))

   (setq lname (cdr (assoc 8 ent)))

  )

  (setq lname (getstring "\nNot to selected, Input layer name: "))

 )

 (if (= (getvar "clayer") lname)

  (setvar "clayer" "0")

 )

 (command "layer" "off" lname "")

 (princ)

)

;;;  2.2 LayerOffM 关闭物体所在的层（多选）

(Defun C:LayerOffM ()

 (setvar "cmdecho" 0)

 (prompt "\nSelect entities to turn off:")

 (setq ss (ssget))

 (if (and

    ss

    (sslength ss)

    0

   )

  (progn

   (setq ct 0

      len (sslength ss)

      cl (getvar "clayer")

   )

   (command ".layer")

   (while (< ct len)

    (setq la (cdr (assoc 8 (entget (ssname ss ct)))))

    (if (/= cl la)

     (command "off" la)

     (progn

      (prompt "\nThe layer")

      (prompt la)

      (prompt "is CURRENT!")

     )

    )

    (if (= old nil)

     (setq OLD la)

     (setq OLD (strcat OLD "," la))

    )

    (setq ct (1+ ct))

   )

   (command "")

  )

 )

 (princ)

 (setvar "cmdecho" 0)

 (prin1)

)

;;;  2.3 LayerOffOther 关闭物体以外的层

(defun c:LayerOffOther (/ ent lname)

 (setvar "cmdecho" 0)

 (setq ent (entsel "\nPick an entity on the target layer: "))

 (if ent

  (progn

   (setq ent (entget (car ent)))

   (setq lname (cdr (assoc 8 ent)))

   (setvar "clayer" lname)

  )

 )

 (command "layer" "off" "*" "n" "")

 (princ)

)

;;;  2.3.1 LayerOffOtherM 关闭物体以外的层（多选）

(Defun C:2 (/ ss ct cl la old)

 (setvar "cmdecho" 0)

 (prompt "\nSelect entities on the layers you want to remain:")

 (setq ss (ssget))

 (setq ct 0

    len (sslength ss)

    cl (cdr (assoc 8 (entget (ssname ss 0))))

 )

 (setvar "clayer" cl)

 (while (< ct len)

  (setq la (cdr (assoc 8 (entget (ssname ss ct)))))

  (if (= old nil)

   (setq OLD la)

   (setq OLD (strcat OLD "," la))

  )

  (setq ct (1+ ct))

 )

 (command ".layer" "off" "*" "n" "")

 (command ".layer" "on" old "")

 (princ)

)

;;; ------------------------------------------------------------------

;;;  2.4 LayerLockM 锁住物体所在的层（多选）

(defun C:4 (/ ES EN EL A)

 (princ "Selected Entity(s) Layers Locked.")

 (setq ES (ssget)

    A 0

    EN ""

    EL nil

    FL nil

 )

 (while (/= EN nil)

  (setq EN (ssname ES A)

     EL (cons EN EL)

     A (1+ A)

  )

 )

 (setq EL (cdr EL)

    FL (cdr (assoc '8 (entget (car EL))))

    EL (cdr EL)

 )

 (repeat (- A 2)

  (setq EN (cdr (assoc '8 (entget (car EL))))

     FL (strcat EN "," FL)

     EL (cdr EL)

  )

 )

 (command "LAYER" "LO" (eval FL) "")

 (princ)

)

;;;  2.5 LayerUnlockM 解锁物体所在的层（多选）

(defun C:5 (/ ES EN EL A)

 (princ "Selected Entity(s) Layers Unlocked.")

 (setq ES (ssget)

    A 0

    EN ""

    EL nil

    FL nil

 )

 (while (/= EN nil)

  (setq EN (ssname ES A)

     EL (cons EN EL)

     A (1+ A)

  )

 )

 (setq EL (cdr EL)

    FL (cdr (assoc '8 (entget (car EL))))

    EL (cdr EL)

 )

 (repeat (- A 2)

  (setq EN (cdr (assoc '8 (entget (car EL))))

     FL (strcat EN "," FL)

     EL (cdr EL)

  )

 )

 (command "LAYER" "U" (eval FL) "")

 (princ)

)

;;; ------------------------------------------------------------------

;;;  2.6 LayerFreezeM 冻结物体所在的层（多选）

(defun C:LayerFreezeM (/ ES EN EL A)

 (princ "Selected Entity(s) Layers Freezed.")

 (setq ES (ssget)

    A 0

    EN ""

    EL nil

    FL nil

 )

 (while (/= EN nil)

  (setq EN (ssname ES A)

     EL (cons EN EL)

     A (1+ A)

  )

 )

 (setq EL (cdr EL)

    FL (cdr (assoc '8 (entget (car EL))))

    EL (cdr EL)

 )

 (repeat (- A 2)

  (setq EN (cdr (assoc '8 (entget (car EL))))

     FL (strcat EN "," FL)

     EL (cdr EL)

  )

 )

 (command "LAYER" "F" (eval FL) "")

 (princ)

)

;;;  2.7 LayerThawAll 解冻所有的层

(Defun C:LayerThawAll ()

 (COMMAND "LAYER" "THAW" "*" "")

 (PRINC)

)

;;; ------------------------------------------------------------------

;;;  2.8 LayerCurrent 将物体所在的层设为当前层

(defun c:LayerCurrent (/ ent lname)

 (setvar "cmdecho" 0)

 (setq ent (car (entsel "\nPick an entity on the target layer: ")))

 (if ent

  (progn

   (setq ent (entget ent)

      lname (cdr (assoc 8 ent))

   )

  )

  (progn

   (setq lname (getstring "\nNot to selected, Input layer name: "))

  )

 )

 (setvar "clayer" lname)

 (princ)

)

;;; ------------------------------------------------------------------

;;;  2.9 LayerOnAll 打开所有层

(Defun C:3 ()

 (command "layer" "on" "*" "")

 (princ)

)

;;; ------------------------------------------------------------------

;;;  2.10 ToCurrentLayerM 将物体转到当前层（多选），并使用层颜色，线型

(defun c:ToCurrentLayerM (/ lname ss)

 (setq ss (ssget))

 (if ss

  (progn

   (setq lname (getvar "clayer"))

   (command "chprop" ss "" "la" lname "color" "bylayer" "ltype" "bylayer"

        ""

   )

  )

 )

)

;;; ------------------------------------------------------------------

;;;  2.11 ToLayerMatch 通过目标物体改变选择实体的图层属性

(defun c:ToLayerMatch (/ lname ss ent)

 (setvar "cmdecho" 0)

 (prompt "\nSelect the entity(s): ")

 (setq ss (ssget))

 (if ss

  (progn

   (setq ent (entsel "\nPick an entity on the target layer: "))

   (if ent

    (progn

     (setq ent (entget (car ent)))

     (setq lname (cdr (assoc 8 ent)))

    )

    (progn

     (setq lname (getstring "\nNot to selected, Input layer name: "))

    )

   )

   (command "chprop" ss "" "la" lname "")

  )

 )

 (princ)

)

快捷键1-掩藏图层  快捷键2-只显示选中图层  快捷键3-显示全部图层

000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000

2.增强复制

;;;********************************************************图形矫正程序-jz

(defun c:cc (/ p1 p2 s e cn)

 ;__________________

  (defun ttt (ss n / m)

    (setq ee e

   ns (ssadd)

    )

    (while (setq ee (entnext ee))

      (setq ns (ssadd ee ns))

    )

    (command "erase" ns "")

    (command "copy" ss "" "m" "non" p1)

    (setq m 0)

    (repeat (atoi n)

      (setq m (1+ m))

      (cond

 ((= "/" (substr n (strlen n)))

  (command

    "non"

    (mapcar '(lambda (x y) (+ x (* m (/ (- y x) (atof n)))))

     p1

     p2

    )

  )

 )

 (t

  (command "non"

    (mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2)

  )

 )

      )

    )

    (command)

  )

 ;__________________

    (princ "\n选择要复制的物体:")

  (setq s (ssget))

  (setq p1 (getpoint "\n复制的起点:"))

  (setq p2 (getpoint p1 "\n复制的终点:"))

  (setq e (entlast))

  (command "copy" s "" "non" p1 "non" p2)

  (while (/= 0

      (atof (setq cn (getstring "\n份数(以 / 结束为等分):")))

  )

    (ttt s cn)

  )

  (princ)

)

(defun c:c1 (/ p1 p2 s e cn a1 d1 ns cnn)

 ;__________________

  (defun ttt (ss n / m)

    (setq ee e

   ns (ssadd)

    )

    (while (setq ee (entnext ee))

      (setq ns (ssadd ee ns))

    )

    (command "erase" ns "")

    (command "copy" ss "" "m" "non" p1)

    (if (member (substr n (strlen n)) '("/" "*"))

      (progn

 (setq m 0)

 (repeat (atoi n)

   (setq m (1+ m))

   (cond

     ((= "/" (substr n (strlen n)))

      (command

        "non"

        (mapcar '(lambda (x y) (+ x (* m (/ (- y x) (atof n)))))

         p1

         p2

        )

      )

     )

     ((= "*" (substr n (strlen n)))

      (command "non"

        (mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2)

      )

     )

   )

 )

      )

      (command "non" (setq p2 (polar p1 a1 (atof n))))

    )

    (command)

  )

 ;__________________

  (princ "\n选择要复制的物体:")

  (setq s (ssget))

  (setq p1 (getpoint "\n复制的起点:"))

  (command "undo" "be" "line" p1 p1 "")

  (setq e (entlast))

  (command "copy" s "" "non" p1 pause)

  (setq p2 (getvar "lastpoint")

 a1 (angle p1 p2)

 d1 (distance p1 p2)

  )

  (setq cn "1*")

  (while cn

    (ttt s cn)

    (initget 128)

    (princ

      "\n输入坐标=复制终点                         输入数值=修改间距 "

    )

    (princ

      "\n输入数值n并以 / 结束=间距内等分n次复制    输入数值n并以 * 结束=按间距复制n次 "

    )

    (setq cnn (getpoint "\n请按提示输入<退出>:"))

    (if (= 'LIST (type cnn))

      (setq p2 cnn

     a1 (angle p1 p2)

     d1 (distance p1 p2)

      )

      (setq cn cnn)

    )

  )

  (entdel e)

  (command "undo" "e")

  (princ)

)

(defun c:c2 (/ p1 p2 s e cn)

 ;__________________

  (defun ttt (ss n / m)

    (setq ee e

   ns (ssadd)

    )

    (while (setq ee (entnext ee))

      (setq ns (ssadd ee ns))

    )

    (command "erase" ns "")

    (command "copy" ss "" "m" "non" p1)

    (setq m 0)

    (repeat (atoi n)

      (setq m (1+ m))

      (cond

 ((= "/" (substr n (strlen n)))

  (command

    "non"

    (mapcar '(lambda (x y) (+ x (* m (/ (- y x) (atof n)))))

     p1

     p2

    )

  )

 )

 (t

  (command "non"

    (mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2)

  )

 )

      )

    )

    (command)

  )

 ;__________________

  (princ "\n选择要复制的物体:")

  (setq s (ssget))

  (setq p1 (getpoint "\n复制的起点:"))

  (setvar "lastpoint" p1)

     ;(setq p2 (getpoint p1 "\n复制的终点:"))

  (setq e (entlast))

  (command "copy" s "" "non" p1 pause)

  (if (not (equal p1 (setq p2 (getvar "lastpoint"))))

    (while (/= 0

        (atof (setq cn (getstring "\n份数(以 / 结束为等分):")))

    )

      (ttt s cn)

    )

  )

  (princ)

)

;;;|增强拷贝

(defun c:c3 (/ getpt getpt1 ss ptx pty db n x y gtin)

  (setq getpt1 (acet-ss-drag-move

   (setq ss (ssget))

   (setq getpt (getpoint "\n&点取基点:"))

   1

        )

  )

  (setq ptx (- (car getpt1) (car getpt))

 pty (- (cadr getpt1) (cadr getpt))

 y   0

  )

  (vl-cmdf ".copy" ss "" getpt getpt1)

  (while (setq gtin (- (getint "\n重复次数:") 1))

    (vl-cmdf ".undo" "e")

    (if (/= y 0)

      (vl-cmdf ".u")

    )

    (setq n  1

   x  0

   db nil

    )

    (if (/= y 0)

      (vl-cmdf ".u")

    )

    (vl-cmdf ".undo" "be")

    (repeat gtin

      (setq db (cons (list (+ (* n ptx) (car getpt1))

      (+ (* n pty) (cadr getpt1))

      0.0

       )

       db

        )

      )

      (setq n (1+ n))

    )

    (repeat (length db)

      (vl-cmdf ".copy" ss "" getpt (nth x (reverse db)))

      (setq x (1+ x))

    )

    (vl-cmdf ".undo" "e")

    (vl-cmdf ".undo" "be")

    (setq y (1+ y))

  )

  (princ)

)

快捷键C1-等分复制  快捷键C2-多重复制

000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000

3.墙柱工具无敌（雨夜屠夫）

 VLX文件，自己上网搜索。