找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 26553|回复: 133

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

    [复制链接]
发表于 2013-4-25 15:36:46 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有账号?立即注册

×
1 删除子实体,用在临时删除图块中的某一实体,比Refedit便捷
[pcode=lisp,true](defun c:delsubent (/ e)
  (while (setq e (nentsel))
    (vla-delete (vlax-ename->vla-object (car e)))
    (if        (= (length e) 4)
      (mapcar 'entupd (last e))
    )
  )
  (princ)
)[/pcode]

评分

参与人数 3D豆 +15 收起 理由
Lispboy + 5 很给力!经验;技术要点;资料分享奖!
xshrimp + 5 很给力!经验;技术要点;资料分享奖!
炫翔 + 5 很给力!经验;技术要点;资料分享奖!

查看全部评分

本帖被以下淘专辑推荐:

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

25 锁定图层[pcode=lisp,true](defun c:lyrlk (/ *acad* doc)
  (setq        *acad* (vlax-get-acad-object)
        doc    (vla-get-activedocument *acad*)
  )
  (vla-startundomark doc)
  (vl-catch-all-apply
    '(lambda (/ lyr e)
       (while (setq e (car (entsel "\nSelect Lock Layer: ")))
         (setq lyr (cdr (assoc 8 (entget e))))
         (vla-eval
           (vlax-get-acad-object)
           (strcat "Thisdrawing.layers.Item(\"" lyr "\").Lock = True")
         )
       )
     )
  )
  (vla-endundomark doc)
  (vlax-release-object doc)
  (vlax-release-object *acad*)
  (princ)
)[/pcode]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 2 反对 0

使用道具 举报

已领礼包: 68个

财富等级: 招财进宝

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

使用道具 举报

 楼主| 发表于 2013-5-2 17:02:41 | 显示全部楼层
本帖最后由 Free-Lancer 于 2013-5-2 17:06 编辑

13 循环修改文字示例,可以是块中的文字、属性、多行文字[pcode=lisp,true] ;|
循环修改文字示例,可以是块中的文字、属性、多行文字
|;
(defun c:ChgTxt ()
  (vl-catch-all-apply
    (function
      (lambda (/ e vla-object)
        (while (and (setq e (nentsel "\n选择文字<退出>: "))
                    (setq vla-object
                           (vlax-ename->vla-object (car e))
                    )
                    (member (vla-get-objectname vla-object)
                            '("AcDbText" "AcDbAttribute" "AcDbMtext")
                    )
               )
          (princ (strcat "\n原文字: "
                         (vla-get-textstring vla-object)
                 )
          )
          (vla-put-textstring
            vla-object
            (getstring "\n新文字: ")
          )
          (if (> (length e) 2)
            (vla-update
              (vlax-ename->vla-object (last (last e)))
            )
          )
        )
      )
    )
  )
  (princ)
)[/pcode]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 0 反对 1

使用道具 举报

 楼主| 发表于 2013-5-2 08:57:34 | 显示全部楼层
6 Line编号
根据Line起点由下向上编号
[pcode=lisp,true](defun c:tt (/ ss sl i e el ms n)
  (setq        ms (vla-get-modelspace
             (vla-get-activedocument (vlax-get-acad-object))
           )
        n  1
  )
  (if (setq ss (ssget '((0 . "line"))))
    (progn
      (setq sl (sslength ss)
            i  -1
      )
      (repeat sl
        (setq e         (ssname ss (setq i (1+ i)))
              el (cons (vlax-curve-getstartpoint e) el)
        )
      )
      (setq el (vl-sort el '(lambda (e1 e2) (< (cadr e1) (cadr e2)))))
      (foreach x el
        (vla-addtext ms (itoa n) (vlax-3d-point x) 2.5)
        (setq n (1+ n))
      )
    )
  )
  (princ)
)[/pcode]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 1 反对 0

使用道具 举报

 楼主| 发表于 2013-5-2 08:53:55 | 显示全部楼层
5 实体中心缩放
因为使用了VBA,2010以上要单独安装,不过对Lisper爱好者,最好安装,写程序会更便捷
[pcode=lisp,true](defun c:tt (/ mp up midp scl  d0 d)
  (vla-eval (vlax-get-acad-object)
            "Thisdrawing.activeselectionset.delete"
  )
  (initget 128 "R")
  (setq scl (getdist "\nScalefactor[Reference]: "))
  (cond
    ((and (= scl "R")
          (setq d0 (getdist "\nOld Length: "))
          (setq d (getdist "\nNew Length: "))
     )
     (setq scl (/ d d0))
    )
    ((= (type scl) 'REAL) scl)
    (t (exit))
  )
  (if (ssget)
    (vlax-for obj (vla-get-activeselectionset
                    (vla-get-activedocument (vlax-get-acad-object))
                  )
      (vla-getboundingbox obj 'Mp 'up)
      (setq
        midp (mapcar
               '(lambda (x) (* 0.5 x))
               (mapcar '+ (safearray-value mp) (safearray-value up))
             )
      )
      (vla-scaleentity obj (vlax-3d-point midp) scl)
    )
  )
  (princ)
)[/pcode]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 1 反对 0

使用道具 举报

 楼主| 发表于 2013-4-25 15:45:38 | 显示全部楼层
2 Pline"复制"某一段

  1. (vl-load-com)
  2. (defun c:tt (/ doc ms)
  3.   (setq        doc (vla-get-activedocument (vlax-get-acad-object))
  4.         ms  (vla-get-modelspace doc)
  5.   )
  6.   (vla-startundomark doc)
  7.   (vl-catch-all-apply
  8.     (function
  9.       (lambda (/ e el p ent pt i p1 p2 pl)
  10.         (while (and
  11.                  (setq e (entsel "\nSelect Polyline: "))
  12.                  (setq el (entget (car e)))
  13.                  (= (cdr (assoc 0 el)) "LWPOLYLINE")
  14.                )
  15.           (setq        p   (cadr e)
  16.                 ent (vlax-ename->vla-object (car e))
  17.           )
  18.           (setq        pt (vlax-curve-getclosestpointto ent p)
  19.                 i  (fix (vlax-curve-getparamatpoint ent pt))
  20.                 p1 (vlax-curve-getpointatparam ent i)
  21.                 p2 (vlax-curve-getpointatparam ent (1+ i))
  22.           )
  23.           (vla-setbulge
  24.             (setq pl (vlax-invoke
  25.                        ms
  26.                        'addlightweightpolyline
  27.                        (list (car p1) (cadr p1) (car p2) (cadr p2))
  28.                      )
  29.             )
  30.             0
  31.             (vla-getbulge ent i)
  32.           )
  33.           (vla-put-color pl acGreen)
  34.           (vla-put-ConstantWidth pl 0.1)
  35.         )
  36.       )
  37.     )
  38.     nil
  39.   )
  40.   (vla-endundomark doc)
  41.   (princ)
  42. )
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 394个

财富等级: 日进斗金

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

使用道具 举报

 楼主| 发表于 2013-4-25 16:48:23 | 显示全部楼层
3 两条线分别等分并连线加标注
[pcode=lisp,true](defun c:tt (/ e1 e2 n pts1 pts2 p1 p2 p divdby getstart adim tf tf1 p0 an d)
  (defun divdby        (e n / l d pts $d)
    (setq l  (vlax-curve-getdistatparam e (vlax-curve-getendparam e))
          $d (/ l n)
          d  (- $d)
    )
    (repeat (1+ n)
      (setq pts        (cons (vlax-curve-getpointatdist e (setq d (+ $d d)))
                      pts
                )
      )
    )
    (reverse pts)
  )
  (defun getstart (p e)
    (if        (< (distance p (vlax-curve-getstartpoint e))
           (distance p (vlax-curve-getendpoint e))
        )
      t
      nil
    )
  )
  (defun adim (pts p)
    (mapcar '(lambda (x y)
               (vla-AddDimAligned
                 ms
                 (vlax-3d-point x)
                 (vlax-3d-point y)
                 (vlax-3d-point p)
               )
             )
            pts
            (cdr pts)
    )
  )
  (while (and (setq e1 (entsel "\nPick First Line: "))
              (setq e2 (entsel "\nPick Second Line: "))
              (setq n (getint "\nDivide: "))
              (setq p (getpoint (cadr e2) "\nDimension Location: "))
         )
    (setq p1   (cadr e1)
          p2   (cadr e2)
          e1   (car e1)
          e2   (car e2)
          tf   (getstart p1 e1)
          tf1  (getstart p2 e2)
          pts1 (divdby e1 n)
          pts2 (divdby e2 n)
          ms   (vla-get-modelspace
                 (vla-get-activedocument (vlax-get-acad-object))
               )
          p0   (vlax-curve-getclosestpointto e2 p)
          an   (angle p0 p)
    )
    (if        (not tf)
      (setq pts1 (reverse pts1))
    )
    (if        (not tf1)
      (setq pts2 (reverse pts2))
    )
    (mapcar '(lambda (x y)
               (vla-put-color (vla-addline ms (vlax-3d-point x) (vlax-3d-point y)) acred)
             )
            pts1
            pts2
    )
    (adim pts1          (polar p1 (+ an pi) (distance p p0))    )
    (adim pts2 p)
  )
  (princ)
)
[/pcode]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 308个

财富等级: 日进斗金

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

使用道具 举报

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

使用道具 举报

已领礼包: 2226个

财富等级: 金玉满堂

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

使用道具 举报

已领礼包: 1261个

财富等级: 财源广进

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

使用道具 举报

 楼主| 发表于 2013-4-26 11:46:20 | 显示全部楼层
4 多重打断
[pcode=lisp,true](defun c:Mbrk (/ thisdrawing)
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark thisdrawing)
  (vl-catch-all-apply
    (function
      (lambda (/ ss p1 p2 ssl e)
        (while
          (and
            (progn
              (prompt "\n请选取要截断的实体<退出>:")
              (setq ss (ssget '((0 . "*line,arc,circle,ellipse"))))
            )
            (setq p1 (getpoint "\n起始点<退出>:"))
            (setq p2 (getpoint "\n结束点<退出>:"))
          )
           (if ss
             (progn
               (setq ssl (sslength ss))
               (while (> ssl 0)
                 (setq e (ssname ss (setq ssl (1- ssl))))
                 (vl-cmdf ".break"
                          (list e p1)
                          "F"
                          p1
                          p2
                 )
               )
             )
           )
        )
      )
    )
  )
  (vla-endundomark thisdrawing)
  (princ)
)[/pcode]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2688个

财富等级: 家财万贯

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

使用道具 举报

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

使用道具 举报

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

使用道具 举报

 楼主| 发表于 2013-5-2 09:05:22 | 显示全部楼层
7 找Pline内部一个点
利用了一个辅助线,辅助线和Pline的两个交点之中点肯定在Pline内部[pcode=lisp,true](defun pt-inm (obj ms / bp ep ln)
  (vla-getboundingbox obj 'bp 'ep)
  (setq        ln (vla-addline
             ms
             (vlax-make-variant bp)
             (vlax-make-variant ep)
           )
  )
  (vl-catch-all-apply
    '(lambda (/ pts ptl)
       (setq pts (vlax-invoke obj 'intersectwith ln acextendnone))
       (while pts
         (setq ptl (cons (list (car pts) (cadr pts) (caddr pts)) ptl)
               pts (cdddr pts)
         )
       )
       (if (equal (vlax-curve-getclosestpointto obj (car ptl))
                  (car ptl)
                  1e-8
           )
         (setq p (mapcar '(lambda (x y) (* (+ x y) 0.5))
                         (car ptl)
                         (cadr ptl)
                 )
         )
         (setq p (mapcar '(lambda (x y) (* (+ x y) 0.5))
                         (cadr ptl)
                         (caddr ptl)
                 )
         )
       )
     )
  )
  (vla-delete ln)
  p
)
(defun c:tt (/ e ms p)
  (setq ms (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
        e (car (entsel))
        )
  (setq p (pt-inm (vlax-ename->vla-object e) ms))
  (vla-addpoint ms (vlax-3d-point p))
  (princ)
)[/pcode]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 04:52 , Processed in 0.372915 second(s), 71 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

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