autocad二次开发LISP函数(备用)

;;;保存为DXF文件
(defun c:save_dxf (/)
  (setq    filepath (strcat (getvar "dwgprefix")
             "转换"
             (substr (getvar "dwgname")
                 1
                 (- (strlen (getvar "dwgname")) 4)
             )
             ".dxf"
         )
  )
  (command "save" filepath "16" "")
  (princ)
  (princ "\n文件保存到:")
  (princ filepath)
  (princ)
)

;;根据比例尺计算出图范围中心
(defun get_extent_center (scale paper_w paper_h / xn yn)
  ;;scale比例尺 ,paper_w paper_h出图的宽和高
  (setq re nil)
  (setq xn (* (/ (* paper_w scale) 1000.00) 0.5))
  (setq yn (* (/ (* paper_h scale) 1000.00) 0.5))
  (setq center (list xn yn))
  (setq re center)
)
;;;根据拉框范围计算比例尺
(defun calculate_scale (p1 p2 paper_w paper_h /)
  ;;p1,p1框的角点,paper_w paper_h出图的宽和高
  (setq re nil)
  (setq    scale
     (*
       100
       (ceil
         (/    (* 1000
           (sqrt
             (+    (* (- (car p1) (car p2)) (- (car p1) (car p2)))
            (* (- (cadr p1) (cadr p2)) (- (cadr p1) (cadr p2)))
             )
           )
        )
        (* 100 (sqrt (+ (* paper_w paper_w) (* paper_h paper_h))))
         )
       )
     )
  )
  (setq re scale)
)


;;;改变块的比例
(defun c:modify_scale (/)
  (vl-load-com)
  (setq en (car (entsel))) ;;取块
  (setq scale (getreal))   ;;取比例
  (setq ename (vlax-ename->vla-object en))
  (setq    xscale (vla-get-xscalefactor ename)
    yscale (vla-get-yscalefactor ename)
    zscale (vla-get-zscalefactor ename)
  )
  (if (> xscale 0)
    (setq xscale scale)
    (setq xscale (- scale))
  )
  (if (> yscale 0)
    (setq yscale scale)
    (setq yscale (- scale))
  )
  (vla-put-xscalefactor ename xscale)
  (vla-put-yscalefactor ename yscale)
  (vla-put-zscalefactor ename zscale)
)
;;向上取整函数
(defun ceil (number / int_number)
  (setq re nil)
  (setq int_number (fix number))
  (if (/= (- int_number number) 0)
    (setq int_number (+ 1 int_number))
  )
  (setq re int_number)
)

;;;修改块的Z坐标
(defun c:set_hight (/ i en enlist key h ss ptx pty)
  (setq h (getreal "\n输入新标高："))
  (if (= h nil)
    (setq h 0)
  )
  (setq key (getreal "\n输入阀值："))
  (if (= key nil)
    (setq key 0)
  )
  (setq ss (ssget "x" '((0 . "insert") (8 . "*"))))
  (setq    i     0
    sslen (sslength ss)
  )
  (while (< i sslen)
    (progn
      (setq en (ssname ss i))
      (setq elist (entget en))
      (if (> (caddr (cdr (assoc 10 elist))) key)
    (progn
      (setq ptx (cadr (assoc 10 elist)))
      (setq pty (caddr (assoc 10 elist)))
      (setq
        elist (subst (cons 10 (list ptx pty h))
             (assoc 10 elist)
             elist
          )
      )
      (entmod elist)
    )
      )
      (setq i (+ i 1))
    )
  )
  (princ "\n共处理")
  (princ (+ i 1))
  (princ "个要素。")
  (princ)
)

;;;修改标高

(defun c:set_hight (/ i en enlist key h ss)
  (setq h (getreal "\n输入新标高："))
  (if (= h nil)
    (setq h 0)
  )
  (setq key (getreal "\n输入阀值："))
  (if (= key nil)
    (setq key 0)
  )
  (setq ss (ssget "x" '((8 . "*"))))
  (setq    i     0
    sslen (sslength ss)
  )
  (while (< i sslen)
    (progn
      (setq en (ssname ss i))
      (setq elist (entget en))
      (if (> (cdr (assoc 38 elist)) key)
    (progn
      (setq
        elist (subst (cons 38 h) (assoc 38 elist) elist)
      )
      (entmod elist)
    )
      )
      (setq i (+ i 1))
    )
  )
)




;;;输入图元名取得点列表
(defun get_pointlist (en / ed len i ptl)
  (setq re nil)
  (setq ed (entget en))
  (setq    len (length ed)
    i   0
  )
  (setq ptl (list))
  (while (< i len)
    (if    (= 10 (car (nth i ed)))
      (progn
    (setq ptl (cons (cdr (nth i ed)) ptl))
      )
    )
    (setq i (+ 1 i))
  )
  (setq re ptl)
)
;;;输入两个点表ptl1,ptl2, 判断ptl1是不是PTL2的子集，是则返回T，否返回NIL （用来判断是否有重叠图形）
(defun equal_pointlist (ptl1 ptl2 / i j pt1 pt2)
  (setq    len1  (length ptl1)
    i     0
    count 0
  )
  (while (< i len1)
    (setq pt1 (nth i ptl1))
    (setq len2 (length ptl2)
      j    0
    )
    (while (< j len2)
      (setq pt2 (nth j ptl2))
      (if (= (equal pt1 pt2) T)
    (progn
      (setq count (+ 1 count))
    )
      )
      (setq j (+ 1 j))
    )
    (setq i (+ 1 i))
  )
  (setq end nil)
  (if (= count len1)
    (setq end t)
  )
  (setq re end)
)
;;;获取文件路径
(defun get_path
        (setq
         filepath
         (strcat (getvar "dwgprefix") (getvar "dwgname"))
        )
)
;;;获取面积（不能处理岛）
(defun get_area    (en / area)
  (vl-load-com)
  (setq obj (vlax-ename->vla-object en))
  (set area (vla-get-area obj))
  (setq re area)
)
;;;岛编组,返回编组数
(defun c:island_setgroup (/)
  (setvar "cmdecho" 0)
  (command "zoom" "e")
  (vl-load-com)
  (setq sspl (ssget "x" (list (cons 0 "*POLYLINE"))))
  (if sspl
    (progn
      (setq sspllen    (sslength sspl)
        i        0
        group_count    0
      )
      (while (< i sspllen)
    (setq en (ssname sspl i))
    (setq ed (entget en))
    (setq len (length ed)
          j      0
    )
    (setq ptl (list))
    (while (< j len)
      (if (= 10 (car (nth j ed)))
        (progn
          (setq ptl (cons (cdr (nth j ed)) ptl))
        )
      )
      (setq j (+ 1 j))
    )
    (setq obj1 (vlax-ename->vla-object en))
    (setq area1 (vla-get-area obj1))
    (setq gs (ssadd))
    (setq ssisland (ssget "wp" ptl (list (cons 0 "*POLYLINE"))))
    (if ssisland
      (if (> (sslength ssisland) 0)
        (progn
          (setq k    0
            len    (sslength ssisland)
          )
          (while (< k len)
        (setq en2 (ssname ssisland k))
        (if (/= en en2)
          (progn
            (setq obj2 (vlax-ename->vla-object en2))
            (setq area2 (vla-get-area obj2))
            (if    (= (equal area1 area2 0.000001) nil)
              (setq gs (ssadd en2 gs))
            )
          )
        )
        (setq k (+ 1 k))
          )
        )
      )
    )
    (if (> (sslength gs) 0)
      (progn
        (setq group_count (+ 1 group_count))
        (setq gs (ssadd en gs))
        (command "group" "c" (strcat "G" (rtos i 2 0)) "" gs "")
      )
    )
    (setq i (+ 1 i))
      )
    )
  )
  (setq re group_count)
  (setvar "cmdecho" 1)
)
;;;删除多余的线与重合形,返回删除数
(defun del_line    (/    ss     s      slen   sslen  i       j
         en1    en2    ed2    ed     obj1   obj2   area1
         area2    cover_count   dels
        )
  (command "zoom" "e")
  (setq ss (ssget "x"))
  (if ss
    (progn
      (setq sslen (sslength ss)
        i      0
      )
      (while (< i sslen)
    (setq en1 (ssname ss i))
    (setq ed (entget en1))
    (setq obj1 (vlax-ename->vla-object en1))
    (setq area1 (vla-get-area obj1))
    (setq ptl (get_pointlist en1))
    (setq dels (ssadd))
    (setq s (ssget "wp" ptl))
    (if s
      (progn
        (setq slen          (sslength s)
          j          0
          cover_count 0
        )
        (while (< j slen)
          (setq en2 (ssname s j))
          (setq ptl2 (get_pointlist en2))
          (if (= (equal en1 en2) nil)
        (progn
          (setq obj2 (vlax-ename->vla-object en2))
          (setq area2 (vla-get-area obj2))
          (if (or (= (equal area1 area2 0.000001) T)
              (= (equal_pointlist ptl2 ptl) T)
              )
            (progn (setq dels (ssadd en2 dels))
               (setq cover_count (+ 1 cover_count))
            )
          )
        )
          )
          (setq j (+ 1 j))
        )
      )
    )
    (if (> (sslength dels) 0)
      (command "erase" dels "")
    )
    (setq i (+ 1 i))
      )
    )
  )
)