设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

楼主: Free-Lancer

[他山之石] 一些随手写的小工具(慢慢更新)

   关闭 [复制链接]
 楼主| 发表于 2013-5-6 11:22:45 | 显示全部楼层
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]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2013-5-6 11:28:48 | 显示全部楼层
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]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

点击这里给我发消息

已领礼包: 74个

财富等级: 招财进宝

发表于 2013-5-6 20:43:39 | 显示全部楼层
感谢分享!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-5-7 11:44:06 | 显示全部楼层
灰常的好,谢谢
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2013-5-7 14:52:53 | 显示全部楼层
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]

点评

选择对象: 指定对角点: 找到 7 个 选择对象: *取消* 命令: 不会删除。。验证过了~  发表于 2013-5-10 08:19
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-5-7 18:09:21 | 显示全部楼层

如果是部分重叠怎么处理“
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

 楼主| 发表于 2013-5-7 18:17:59 | 显示全部楼层
fkyourmather 发表于 2013-5-7 18:09
如果是部分重叠怎么处理“

部分重叠和这不是一个概念,你可以看看 Overkill
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-5-9 19:36:48 | 显示全部楼层
:)感谢楼主的分享
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-5-9 23:39:06 来自手机 | 显示全部楼层
恩~overkil 目前没有研究透
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-5-10 07:29:07 | 显示全部楼层
:funk::funk:太强大了~~~
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-5-10 13:30:24 | 显示全部楼层
好东西,谢谢分享
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

点击这里给我发消息

发表于 2013-5-10 13:45:14 | 显示全部楼层
强大的帖子:lol
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-5-10 16:16:26 | 显示全部楼层
感谢分享!:)
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-5-11 12:04:38 | 显示全部楼层

感谢楼主分享,学习中!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 35个

财富等级: 招财进宝

发表于 2013-5-11 23:57:16 | 显示全部楼层
顶楼主的无私奉献精神
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|小黑屋|手机版|Archiver|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )  

GMT+8, 2020-12-6 01:50 , Processed in 0.211324 second(s), 88 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表