一些随手写的小工具（慢慢更新）

Free-Lancer

43 好像是在处理等高线时进行等高线赋值(原Z值丢失)[pcode=lisp,true](setq *doc* (vla-get-activedocument (vlax-get-acad-object))
      *ms*  (vla-get-modelspace *doc*)
)
(defun c:3dpl (/ fy:plt ss pts ptl v pl)
  (defun fy:plt        (e / epam i pts)
    (setq epam (vlax-curve-getendparam e)
          i    0
    )
    (repeat (1+ (fix epam))
      (setq pts        (cons (vlax-curve-getpointatparam e i) pts)
            i        (1+ i)
      )
    )
    pts
  )
  (if (setq ss (ssget '((0 . "POLYLINE"))))
    (progn
      (vlax-for        obj *doc*
        (if (= (vla-get-objectname obj) "AcDb3dPolyline")
          (progn
            (setq pts nil
                  ptl nil
                  pts (fy:plt obj)
                  v   (last (car pts))
                  pts (apply 'append pts)
            )
            (while pts
              (setq ptl        (cons (list (car pts) (cadr pts)) ptl)
                    pts        (cdddr pts)
              )
            )
            (vla-put-elevation
              (setq pl (vlax-invoke
                         *ms*
                         'addlightweightpolyline
                         (apply 'append ptl)
                       )
              )
              v
            )
            (vla-put-color pl acred)
            (vla-delete obj)
          )
        )
      )
    )
  )
  (princ)
)
(defun c:dgxb (/ ss)
  (if (setq ss (ssget '((0 . "LWPOLYLINE"))))
    (progn
      (vlax-for        obj (vla-get-activeselectionset *doc*)
        (vla-put-color
          (vla-addtext
            *ms*
            (rtos (vla-get-elevation obj) 2 0)
            (vlax-3d-point (vlax-curve-getstartpoint obj))
            4.
          )
          acgreen
        )
      )
    )
  )
  (princ)
)
(defun c:dgxc (/)
  (if (ssget '((0 . "lwpolyline")))
    (vlax-for obj (vla-get-activeselectionset *doc*)
      (if (zerop (vla-get-elevation obj))
        (vla-put-color obj 10)
      )
    )
  )
)
(defun c:dgxz (/ z bj obj)
  (if (and (setq z (getreal "\nStart Elevation: "))
           (setq bj (getreal "\nSpace Elevation: "))
      )
    (while (ssget '((0 . "lwpolyline")))
      (vlax-for        obj (vla-get-activeselectionset *doc*)
        (vla-put-elevation obj z)
        (vla-put-color obj 7)
      )
      (setq z (+ z bj))
    )
  )
  (princ)
)
(defun c:dgxs (/ e1 e2 obj1 obj2)
  (while (and (setq e1 (car (entsel)))
              (setq e2 (car (entsel)))
         )
    (setq obj1 (vlax-ename->vla-object e1)
          obj2 (vlax-ename->vla-object e2)
    )
    (vla-put-elevation obj2 (vla-get-elevation obj1))
    (vla-put-color obj2 7)
  )
  (princ)
)[/pcode]

Free-Lancer

44  好像是重建高程点[pcode=lisp,true](defun c:tt (/ ss ins att tp str p1 p2 modelspace thisdrawing)
  (setq        thisdrawing (vla-get-activedocument (vlax-get-acad-object))
        modelspace  (vla-get-modelspace thisdrawing)
  )
  (if (setq ss (ssget))
    (progn
      (vlax-for        obj (vla-get-activeselectionset thisdrawing)
        (setq ins (vlax-get obj 'insertionpoint)
              att (car (vlax-invoke obj 'getattributes))
              tp  (vla-get-textalignmentpoint att)
              str (vla-get-textstring att)
              p1  (polar ins pi 0.175)
              p2  (polar ins 0. 0.175)
        )
        (vla-addtext
          modelspace
          str
          (vlax-3d-point
            (list (+ (car ins) 2.1)
                  (- (cadr ins) 1.75)
                  (distof str)
            )
          )
          3.5
        )
        (setq pl (vlax-invoke
                   modelspace
                   'Addlightweightpolyline
                   (list (car p1) (cadr p1) (car p2) (cadr p2))
                 )
        )
        (vla-put-closed pl :vlax-true)
        (vla-setbulge pl 0 1.0)
        (vla-setbulge pl 1 1.0)
        (vla-put-elevation pl (distof str))
        (vla-put-constantwidth pl 0.35)
      )
    )
  )
  (princ)
)[/pcode]

黑洞—杜明智

感谢分享！{:soso_e163:}

fkyourmather

灰常的好，谢谢

Free-Lancer

45 删除完全重复实体[pcode=lisp,true](defun c:removeMEnt (/        ss        ssl        n        t0        t1
                        typ        elst        index        nn        tmp        tmp1
                        line        olderr        a:error        a:table
                        filter        el
                       )
  (defun a:error (st)
    (if        (/= st "函数已取消")
      (princ "\n*取消*")
    )
    (mapcar '(lambda (a) (set a nil)) line)
    (setq line nil)
    (princ)
  )
  (setq        olderr *error*
        *error*        a:error
  )
  (if (setq ss (ssget ":L"))        ;过滤出锁定的图层，CAD的Bug
    (progn
      (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
      (setq t0 (get-utime))
      (setq ssl        (sslength ss)
            n        0
      )
      (while (> ssl 0)
        (setq e (ssname ss (setq ssl (1- ssl))))
        (setq elst  (entget e)
              typ   (cdr (assoc 0 elst))
              elst  (cdr elst)
              elst  (vl-remove-if
                      '(lambda (x)
                         (or (= (car x) 5) (= (car x) 8))
                       )
                      elst
                    )
              index (assoc 10 elst)
              tmp   (eval (read typ))
        )
        (if (= typ "TRACE")
          (setq typ "$TRACE")
        )
        (if index
          (progn
            (setq nn (read (strcat typ (rtos (cadr index) 2 0))))
            (setq tmp1 (eval nn))
            (if        (not tmp1)
              (set nn (list elst))
            )                                ;赋值子表
            (if        (vl-position elst tmp1)
              (progn
                (setq n (1+ n))
                (entdel e)
              )
              (set nn (cons elst tmp1))
            )
            (setq line (cons nn line))        ;保存变量名
          )
          (progn
            (if        (not tmp)                ;其它实体
              (set (read typ) (list elst))
            )
            (if        (vl-position elst tmp)
              (progn
                (setq n (1+ n))
                (entdel e)
              )
              (set (read typ) (cons elst tmp))
            )
            (setq line (cons (read typ) line))
          )
        )
      )
      (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
    )
  )
  (if t0
    (progn
      (setq t1 (get-utime))
      (princ
        (strcat "\n共删除 " (itoa n) " 个重复实体,  耗时(secs): ")
      )
      (princ (if t0
               (- t1 t0)
               0.
             )
      )
    )
  )
  (mapcar '(lambda (a) (set a nil)) line)
  (setq line nil)
  (setq *error* a:olderr)
  (setq a:olderr nil)
  (princ)
)[/pcode]

fkyourmather

Free-Lancer 发表于 2013-5-7 14:52

                               
登录/注册后可看大图

45 删除完全重复实体(defun c:removeMEnt (/        ss        ssl        n        t0        t1
        ...

如果是部分重叠怎么处理“

Free-Lancer

fkyourmather 发表于 2013-5-7 18:09

                               
登录/注册后可看大图

如果是部分重叠怎么处理“

部分重叠和这不是一个概念，你可以看看 Overkill

272824639

:)感谢楼主的分享

fkyourmather

恩～overkil 目前没有研究透

flytodayddc

:funk::funk:太强大了~~~

phoevana

好东西，谢谢分享

laibinwu

强大的帖子:lol

xingwan2013

感谢分享！:)

jack0906

感谢楼主分享，学习中！

lgttblue

顶楼主的无私奉献精神