设为首页收藏本站转
发帖领奖家园QQ群申请版主版主评价切换到宽版

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步，快速开始

扫一扫，访问微社区

晓东CAD家园-论坛»论坛 › ╃CAD编程开发 › 每日插件 › 一个特别强大的修剪程序（可框选和划线修剪）
12下一页
返回列表 发新帖
查看: 1217|回复: 21

[工具] 一个特别强大的修剪程序（可框选和划线修剪）

[复制链接]
好梦压星河啊
发表于 2021-3-17 19:16:26 | 显示全部楼层 |阅读模式

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

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

x
小弟我偶然发现了发现了一个特别强大的修剪程序，可以框选修剪也可以划线修剪，十分方便。但是存在两个问题，第一个问题：外伸距离小于0.2的无法被修剪，第二个问题：只能在世界坐标系中使用，如果在其他坐标系中使用就出错，

希望大佬能帮忙完善一下，把插件附在下面，需要使用的可以自己拿走使用！
  1. ;;可点可框的修剪
  2. (defun c:tt(/ PO SS I J S1 P1 P2 )
  3.   (vl-load-com)
  4.   (setq osvalue (getvar "osmode"))
  5.   (SETVAR "CMDECHO" 0)
  6.   (setvar "osmode" 0)
  7.   (setq  plist NIL ss  nil pt0 nil len NIL)
  8.   (if(setq s1 (ssget))(setq len (sslength s1)))
  9.   (command "undo" "be")
  10.   (cond  ((= len 1);;;;;;;;;;;;;;;;;;;;如果是单选
  11.    (setq po(getpoint "\n请点选要被剪的一侧:") e1(ssname s1 0))
  12.    (command ".offset" 0.2 e1 po "") ;0.2是偏移值，小于0.2会导致修剪不准确
  13.    (setq en(entlast) dx0(dxf 0 e1))
  14.    (if po
  15.        (setq plist(dd en))
  16.    )
  17.    (command "trim" S1 "")
  18.    (repeat 5
  19.      (command "f")
  20.      (apply 'command plist)
  21.      (COMMAND "")
  22.      )
  23.    
  24.    (COMMAND "")
  25.   )
  26.   ((> len 1);;;;;;;;;;如果是多选
  27.    (prompt"\n请选择修剪方式<左击移动/右击框选>:")
  28.    (setq code_12 (grread (setq code (grread))));将类型代码 12 的数据从缓冲区中清除
  29.    (initget 128)
  30.    (if (= (car (setq g (grread nil 4 0))) 3)
  31.       (setq fs 3)
  32.       (setq fs nil)
  33.    )
  34.    (cond ((= fs 3);;;;;如果是左击
  35.     (setq z t)
  36.     (command "trim" s1 "")
  37.     (while z
  38.       (prompt"\n点击鼠标后开始修剪")
  39.       (if g (setq pt(cadr g) g nil)(setq pt (getpoint)))
  40.       (if pt
  41.         (progn (command "f")
  42.                (mapcar'(lambda(x)(command "NON" x))  (getpts))
  43.          (command "")
  44.               )
  45.         (setq z nil)
  46.       )
  47.      )
  48.     (command "")
  49.     )
  50.     ((not fs);;;如果是右击
  51.       (setq  p1 (getpoint "\n请框选被修剪对象:")
  52.       p3 (getcorner p1)
  53.       ss (ssget "c" p1 p3)
  54.       )
  55.       (setq z t)
  56.       (while z;
  57.         (SETq LEN2 (SSLENGTH SS))
  58.         (setq p2 (list (car p1) (cadr p3))
  59.         p4 (list (car p3) (cadr p1))
  60.         )
  61.         (command "trim" s1 "")
  62.         (REPEAT LEN2
  63.           (COMMAND "NON" "f" p1 p2 p3 p4 p1 "")
  64.         )
  65.         (COMMAND "")
  66.         (setq ss nil)
  67.         (initget 128)
  68.         (if  (setq p1 (getpoint "\n请框选被修剪对象:"))
  69.           (setq p3 (getcorner p1)
  70.           ss (ssget "c" p1 p3)
  71.           )
  72.         )
  73.         (if  (not ss)
  74.           (setq z nil)
  75.         )
  76.       );
  77.     );;;
  78.          );;;;;
  79.    );;;;;;;;;;
  80.   ((not len);;如果没有选择
  81.    (command ".trim" "")
  82.    )
  83.   );;;;;;;;;;;;;;;;;;;;
  84.    (command "undo" "e")
  85.    (setvar 'cmdecho 1)
  86.    (setvar 'osmode 1)
  87.    (PRINC)
  88. )
  89. ;;;
  90. (defun dxf(n ename)
  91.   (cdr(assoc n (entget ename)))
  92.   )
  93. ;;;
  94. (defun getpts(/ gr pt0 pt dis)
  95.   (setq pts nil)
  96.   (setq dis (* 0.001 (getvar "viewsize")))
  97.   (while (= 5 (car (setq gr (grread t 4 0))))
  98.     (setq pt (cadr gr))
  99.     (if  (not pt0)
  100.       (setq pt0  pt
  101.       pts  (cons pt0 pts)
  102.       )
  103.     )
  104.     (if  (> (distance pt pt0) dis)
  105.       (progn
  106.   (grdraw pt pt0 1 1)
  107.   (setq pts (cons pt pts)
  108.         pt0 pt
  109.   )
  110.       )
  111.     )
  112.   )
  113.   (redraw)
  114.   (reverse pts)
  115. )
  116. ;;;;
  117. (defun dd (x)
  118.   (setq obj x obj(vlax-ename->vla-object obj))
  119.   (setq zc (vlax-curve-getdistatparam
  120.       obj
  121.       (vlax-curve-getendparam obj)
  122.           )
  123.        )
  124.   (setq et(vlax-curve-getEndPoint obj)
  125.   st(vlax-curve-getStartPoint obj)
  126.   )
  127.   (cond ((= dx0 "LINE")
  128.   (setq plist(append(list st et))))
  129.   ((= dx0 "LWPOLYLINE")
  130.           (mapcar '(lambda (x)
  131.       (if (= (car x) 10)
  132.         (setq plist (cons (cdr x) plist))
  133.       )
  134.           )
  135.          (entget en)
  136.        )
  137.    (if(= 1 (dxf 70 x))(setq p0(car plist) plist(append plist (list p0))))
  138.          )
  139.    ((OR(= dx0 "SPLINE")(= dx0 "CIRCLE")(= dx0 "ELLIPSE"))
  140.             (setq zc(fix zc) k 0)
  141.             (command "_.divide" x zc)
  142.             (setq snew(ssget "p"))
  143.             (repeat (sslength snew)
  144.              (setq s(ssname snew k))
  145.              (setq dx(dxf 10 s))
  146.              (setq plist(cons dx plist))
  147.              (setq k(1+ k))
  148.             )
  149.             (command "erase" snew "")
  150.       (setq plist(reverse plist))
  151.       (IF(/= dx0 "SPLINE")
  152.         (setq plist(append  plist (list et)))
  153.         (setq plist(append (list st) plist (list et)))
  154.       )
  155.     )
  156.    )
  157.   (entdel x)
  158.   plist
  159. )
  160. (setvar "osmode" osvalue )
  161. (setvar "ORTHOMODE" 1)

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

使用道具 举报

xk15c

已领礼包: 914个

财富等级: 财运亨通
发表于 2021-3-18 06:56:11 | 显示全部楼层
做一个快乐学习的人
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

coverne

已领礼包: 6434个

财富等级: 富甲天下
发表于 2021-3-18 08:00:23 | 显示全部楼层
工具箱不香么
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

yuren008

已领礼包: 2223个

财富等级: 金玉满堂
发表于 2021-3-18 09:12:55 | 显示全部楼层
做个对论坛有益的人。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

hbwr123

已领礼包: 1个

财富等级: 恭喜发财
发表于 2021-3-18 10:12:33 | 显示全部楼层
学习一下~~~~~~~~~~
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复

使用道具 举报

hh_lj007

已领礼包: 756个

财富等级: 财运亨通
发表于 2021-3-18 10:24:48 | 显示全部楼层
谢谢分享！
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复

使用道具 举报

hbwr123

已领礼包: 1个

财富等级: 恭喜发财
发表于 2021-3-18 11:01:39 | 显示全部楼层
看了下这代码，局部变量很多没有定义，还有各种缩进、语法问题，看着简直折磨人
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

好梦压星河啊
 楼主| 发表于 2021-3-18 13:49:47 | 显示全部楼层
hbwr123 发表于 2021-3-18 11:01
看了下这代码，局部变量很多没有定义，还有各种缩进、语法问题，看着简直折磨人

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

使用道具 举报

weizx2000

已领礼包: 110个

财富等级: 日进斗金
发表于 2021-3-19 00:09:54 | 显示全部楼层
谢谢分享！~~~~~~~
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复

使用道具 举报

weizx2000

已领礼包: 110个

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

使用道具 举报

hbwr123

已领礼包: 1个

财富等级: 恭喜发财
发表于 2021-3-19 09:11:58 | 显示全部楼层
好梦压星河啊 发表于 2021-3-18 13:49
大佬能帮忙完善一下吗？


楼主平时绘图的单位是0.1以下的吗？注释上说了小于0.2会导致修剪不准确，不要随意修改。除非你的绘图单位很小
  2. (defun dd (x / zc obj et st snew k dx)
  3.       (setq obj (vlax-ename->vla-object x))
  4.       (setq zc (vlax-curve-getdistatparam ;;长度
  5.           obj
  6.           (vlax-curve-getendparam obj)
  7.               )
  8.            )
  9.       (setq et (trans (vlax-curve-getEndPoint obj) 0 1)
  10.           st (trans (vlax-curve-getStartPoint obj) 0 1)
  11.       )
  12.       (cond
  13.         ((= dx0 "LINE")
  14.             (setq plist (append (list st et)))
  15.           )
  16.         ((= dx0 "LWPOLYLINE")
  17.              (mapcar '(lambda (x)
  18.                     (if (= (car x) 10)
  19.                       (setq plist (cons (trans (cdr x) 0 1) plist))
  20.                     )
  21.                     )
  22.             (entget en)
  23.            )
  24.             (if(= 1 (dxf 70 x))(setq plist (append plist (list (car plist)))))
  25.         )
  26.         ((or (= dx0 "SPLINE")(= dx0 "CIRCLE")(= dx0 "ELLIPSE"))
  27.                   (setq zc (fix zc) k 0)
  28.                   (command "_.divide" x zc)
  29.                   (setq snew (ssget "p"))
  30.                   (repeat (sslength snew)
  31.                    (setq s (ssname snew k))
  32.                    (setq dx (dxf 10 s))
  33.                    (setq plist (cons (trans (cdr dx) 0 1) plist))
  34.                    (setq k (1+ k))
  35.                   )
  36.                   (command "erase" snew "")
  37.             (setq plist(reverse plist))
  38.             (if (/= dx0 "SPLINE")
  39.               (setq plist (append  plist (list et)))
  40.               (setq plist (append (list st) plist (list et)))
  41.             )
  42.         )
  43.       )
  44.       (entdel x)
  45.       plist
  46.   )
把函数dd用以上替换一下，解决用户坐标系不能用的问题

  2. (command ".offset" (* 0.001 (getvar "viewsize")) e1 po "")
用以上代码替换下面一行，解决小于0.2会无法裁剪问题
(command ".offset" 0.2 e1 po "")

评分

参与人数 1D豆 +10 收起 理由
HLCAD + 10 热心帮忙奖！

查看全部评分

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

使用道具 举报

xd_黄工
发表于 2021-3-19 10:22:03 | 显示全部楼层
希望多多参与回帖，对帖主鼓励的同时自己还能获得币
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

moonwalkers

已领礼包: 1个

财富等级: 恭喜发财
发表于 2021-3-19 11:32:37 | 显示全部楼层
做一个快乐学习的人
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

好梦压星河啊
 楼主| 发表于 2021-3-19 14:00:03 | 显示全部楼层
本帖最后由 好梦压星河啊 于 2021-3-19 14:40 编辑
hbwr123 发表于 2021-3-19 09:11
楼主平时绘图的单位是0.1以下的吗？注释上说了小于0.2会导致修剪不准确，不要随意修改。除非你的绘图单 ...

非常感谢大佬帮助，我刚刚试了一下，两个问题都已经解决，但是我发现了一个新的问题，就是如果使用该插件期间，按esc退出的话，会导致捕捉设置失效，原插件最后有(setvar "osmode" 487) ，但中途退出不生效，有什么好的解决办法吗？
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

hbwr123

已领礼包: 1个

财富等级: 恭喜发财
发表于 2021-3-20 15:29:27 | 显示全部楼层
本帖最后由 hbwr123 于 2021-3-20 15:31 编辑
好梦压星河啊 发表于 2021-3-19 14:00
非常感谢大佬帮助，我刚刚试了一下，两个问题都已经解决，但是我发现了一个新的问题，就是如果使用该插件 ...

在  (defun c:tt(/ PO SS I J S1 P1 P2 )下一行插入以下代码：
  2. (defun tt:error(msg)
  3.                 (setq *error* olderror olderror nil)
  4.                 (command "undo" "e")
  5.            (setvar 'cmdecho 1)
  6.            (setvar 'osmode osvalue)
  7.                 (princ msg)
  8.         )
  9.         (setq olderror *error* *error* tt:error)


并且把函数c:tt最后的
  (setvar 'osmode 1)
改为
  (setvar 'osmode osvalue)



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

使用道具 举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

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

GMT+8, 2022-8-14 11:04 , Processed in 0.209557 second(s), 46 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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