分享几个简单的LISP实用小程序

(defun c:qx ()     (setvar "cmdecho" 0)  (command "layon")  (setvar "cmdecho" 1) (prin1) ) 打开所有图层

(defun c:ff ()     (setvar "cmdecho" 0)  (command "layoff")  (setvar "cmdecho" 1) (prin1) ) 选择需要关闭的图层

(defun c:qw ()     (setvar "cmdecho" 0)  (command "layiso")  (setvar "cmdecho" 1) (prin1) ) 选择需要隔离的图层

(defun c:tc ()     (setvar "cmdecho" 0)  (command "laymcur")  (setvar "cmdecho" 1) (prin1) ) 选择对象为当前图层

(defun c:df ()     (setvar "cmdecho" 0)  (command "ribbon")  (setvar "cmdecho" 1) (prin1) ) 打开工具选项栏

(defun c:fd ()     (setvar "cmdecho" 0)  (command "ribbonclose")  (setvar "cmdecho" 1) (prin1) ) 关闭工具选项栏

 修改图层

(defun C:XG (/ #os1 &k1 #k1 %k1 &kw i %k2)

 (setvar "cmdecho" 0)

 (setvar "blipmode" 0)

 (setq #os1 (getvar "osmode"))

 (setvar "osmode" 0)

 (setq &k1 (entsel "\n请选择参考图层"))

 (if (= &k1 nil)

  (princ "\n没有选择参考图层")

 )

 (if (/= &k1 nil)

  (progn

   (setq &k1 (car &州弯告k1)

 #k1 (entget &k1)

 %k1 (assoc 8 #k1)

   )

   (princ "\n请选择需要改变的对象")

   (setq &kw (ssget))

   (if (= &kw nil)

    (princ "\n没有选择对象")

   )

   (if (/= &kw nil)

    (progn

     (setq i 0)

     (repeat (sslength &kw)

      (setq &k1 (ssname &kw i)

    #k1 (entget &k1)

    %k2 (assoc 8 #k1)

    #k1 (subst

 %k1

 %k2

 #k1

)

    i (+ i 1)

      )

      (entmod #k1)

     )

     (princ "\n改变图层完成")

    )

   )

  )

 )

 (setvar "osmode" #os1)

 (prin1)

)

一键所有填充对象置后显示,CAD2005以上版本适用 By Gu_xl 2014.07.17

(defun C:ZX5 (/ sortents dict  lst Doc)

 (setvar "cmdecho" 0)

 (setvar "blipmode" 0)

 (vl-load-com)

  (setq  doc

   (vla-get-ActiveDocument

     (vlax-get-acad-object)

   )

  )

  (vlax-for blockdef (vla-get-blocks doc)

    (cond

      (

       (not

   (VL-CATCH-ALL-ERROR-P

     (setq sortents

      (VL-CATCH-ALL-APPLY

        'vla-item

        (list

          (setq dict

  闹念         (vla-GetExtensionDictionary

             blockdef

           )

          )

          "ACAD_SORTENTS"

        )

      )

     )

   )

       )

      )

      ((setq sortents

    册明    (VL-CATCH-ALL-APPLY

    'vla-AddObject

    (list dict "ACAD_SORTENTS" "AcDbSortentsTable")

        )

       )

      )

    )

    (setq lst nil)

    (vlax-for obj blockdef

      (if (= "AcDbHatch" (vla-get-objectname obj))

  (setq lst (cons obj lst))

      )

    )

    (if  lst

      (progn

  (vla-MoveToBottom

    sortents

    (vlax-make-variant

      (vlax-safearray-fill

        (vlax-make-safearray

    vlax-vbobject

    (cons 0 (1- (length lst)))

        )

        lst

      )

    )

  )

      )

    )

  )

  (vla-regen doc :vlax-true)

  (princ)

)

以上复制到记事本，以（.lsp）为后缀命名，加载autoLISP到AutoCAD。这几个命令基本上会用到

写了一个，图如下：

autolisp代码如下：

(defun c:tes ( / &ang1 &ang2 &dis1 &ent1 &kw1 &p1 &p2 &p3 &p4 &p5 &pt1 &pt2 &r1 &r2 x)

 (setvar "cmdecho" 0)

 (setvar "blipmode" 0)

 (if (and (setq &p1 (getpoint "\n请指定圆心"))

          (setq &r1 (getdist &p1 "\n请输入圆半径"))

     )

  (progn

   (setq &r2 (* &r1 2))

 顷模尺  (entmake (list '(0 . "CIRCLE") (cons 10 &p1) (cons 40 &r1)))

   (setq &ent1 (entlast) &kw1 (ssadd) &kw1 (ssadd &ent1 &kw1))

   (setq &p5 (cadr (grread t)))

   (if (= (distance &p1 &p5) 0) (setq &ang1 0) (setq &ang1 (angle &p1 &p5)) )

   (setq &p2 (polar &p1 &ang1 &r2) &p3 (polar &p1 (+ &ang1 (* pi 0.8)) &r2) &p4 (polar &p1 (- &ang1 (* pi 0.8)) &r2))

   (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 3) '(70 . 1) (cons 10 &p1) (cons 10 &p2) (cons 10 &p3)))

   (setq &ang2 (angle &p2 &p4) &pt1 (polar &p2 &ang2 &r2) &dis1 (distance &p1 &pt1) &pt1 (mapcar '(lambda (x) (* x 0.5)) (mapcar '+ &p1 &pt1)))

   (setq &pt2 (polar &p4 &ang2 (* 雀高&r2 -1)) &pt2 (mapcar '(lambda (x) (* x 0.5)) (mapcar '+ &p1 &pt2)))

   (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 4) (cons 10 &p2) '(40 . 0.0) (cons 41 &dis1) (cons 10 &pt1)(cons 10 &pt2) (cons 40 &dis1) '(41 . 0.0) (cons 10 &p4)))

   (setq &p4 (polar &p1 &ang1 (* &r2 -1)) &ang2 (+ &ang1 (* pi 0.5)))

   (entmake (list '(0 . "TEXT") (cons 1 "N") (cons 10 &p4) (cons 40 (* &r1 0.8)) '(41 . 0.6) (cons 50 &ang2) '(72 . 4) (cons 11 &p4)))

  码含 (while (setq &ent1 (entnext &ent1)) (setq &kw1 (ssadd &ent1 &kw1)) )

   (command "ROTATE" &kw1 "" &p1 "R" &p1 &p2)

  )

 )

 (princ)

)

---