一个特别强大的修剪程序（可框选和划线修剪）
小弟我偶然发现了发现了一个特别强大的修剪程序，可以框选修剪也可以划线修剪，十分方便。但是存在两个问题，第一个问题：外伸距离小于0.2的无法被修剪，第二个问题：只能在世界坐标系中使用，如果在其他坐标系中使用就出错，希望大佬能帮忙完善一下，把插件附在下面，需要使用的可以自己拿走使用！
;;可点可框的修剪
(defun c:tt(/ PO SS I J S1 P1 P2 )
(vl-load-com)
(setq osvalue (getvar "osmode"))
(SETVAR "CMDECHO" 0)
(setvar "osmode" 0)
(setqplist NIL ssnil pt0 nil len NIL)
(if(setq s1 (ssget))(setq len (sslength s1)))
(command "undo" "be")
(cond((= len 1);;;;;;;;;;;;;;;;;;;;如果是单选
(setq po(getpoint "\n请点选要被剪的一侧:") e1(ssname s1 0))
(command ".offset" 0.2 e1 po "") ;0.2是偏移值，小于0.2会导致修剪不准确
(setq en(entlast) dx0(dxf 0 e1))
(if po
(setq plist(dd en))
)
(command "trim" S1 "")
(repeat 5
(command "f")
(apply 'command plist)
(COMMAND "")
)
(COMMAND "")
)
((> len 1);;;;;;;;;;如果是多选
(prompt"\n请选择修剪方式<左击移动/右击框选>:")
(setq code_12 (grread (setq code (grread))));将类型代码 12 的数据从缓冲区中清除
(initget 128)
(if (= (car (setq g (grread nil 4 0))) 3)
(setq fs 3)
(setq fs nil)
)
(cond ((= fs 3);;;;;如果是左击
(setq z t)
(command "trim" s1 "")
(while z
(prompt"\n点击鼠标后开始修剪")
(if g (setq pt(cadr g) g nil)(setq pt (getpoint)))
(if pt
(progn (command "f")
(mapcar'(lambda(x)(command "NON" x))(getpts))
(command "")
)
(setq z nil)
)
)
(command "")
)
((not fs);;;如果是右击
(setqp1 (getpoint "\n请框选被修剪对象:")
p3 (getcorner p1)
ss (ssget "c" p1 p3)
)
(setq z t)
(while z;
(SETq LEN2 (SSLENGTH SS))
(setq p2 (list (car p1) (cadr p3))
p4 (list (car p3) (cadr p1))
)
(command "trim" s1 "")
(REPEAT LEN2
(COMMAND "NON" "f" p1 p2 p3 p4 p1 "")
)
(COMMAND "")
(setq ss nil)
(initget 128)
(if(setq p1 (getpoint "\n请框选被修剪对象:"))
(setq p3 (getcorner p1)
ss (ssget "c" p1 p3)
)
)
(if(not ss)
(setq z nil)
)
);
);;;
);;;;;
);;;;;;;;;;
((not len);;如果没有选择
(command ".trim" "")
)
);;;;;;;;;;;;;;;;;;;;
(command "undo" "e")
(setvar 'cmdecho 1)
(setvar 'osmode 1)
(PRINC)
)
;;;
(defun dxf(n ename)
(cdr(assoc n (entget ename)))
)
;;;
(defun getpts(/ gr pt0 pt dis)
(setq pts nil)
(setq dis (* 0.001 (getvar "viewsize")))
(while (= 5 (car (setq gr (grread t 4 0))))
(setq pt (cadr gr))
(if(not pt0)
(setq pt0pt
pts(cons pt0 pts)
)
)
(if(> (distance pt pt0) dis)
(progn
(grdraw pt pt0 1 1)
(setq pts (cons pt pts)
pt0 pt
)
)
)
)
(redraw)
(reverse pts)
)
;;;;
(defun dd (x)
(setq obj x obj(vlax-ename->vla-object obj))
(setq zc (vlax-curve-getdistatparam
obj
(vlax-curve-getendparam obj)
)
)
(setq et(vlax-curve-getEndPoint obj)
st(vlax-curve-getStartPoint obj)
)
(cond ((= dx0 "LINE")
(setq plist(append(list st et))))
((= dx0 "LWPOLYLINE")
(mapcar '(lambda (x)
(if (= (car x) 10)
(setq plist (cons (cdr x) plist))
)
)
(entget en)
)
(if(= 1 (dxf 70 x))(setq p0(car plist) plist(append plist (list p0))))
)
((OR(= dx0 "SPLINE")(= dx0 "CIRCLE")(= dx0 "ELLIPSE"))
(setq zc(fix zc) k 0)
(command "_.divide" x zc)
(setq snew(ssget "p"))
(repeat (sslength snew)
(setq s(ssname snew k))
(setq dx(dxf 10 s))
(setq plist(cons dx plist))
(setq k(1+ k))
)
(command "erase" snew "")
(setq plist(reverse plist))
(IF(/= dx0 "SPLINE")
(setq plist(appendplist (list et)))
(setq plist(append (list st) plist (list et)))
)
)
)
(entdel x)
plist
)
(setvar "osmode" osvalue )
(setvar "ORTHOMODE" 1)
做一个快乐学习的人 工具箱不香么 做个对论坛有益的人。 学习一下~~~~~~~~~~ 谢谢分享！ 看了下这代码，局部变量很多没有定义，还有各种缩进、语法问题，看着简直折磨人 hbwr123 发表于 2021-3-18 11:01
看了下这代码，局部变量很多没有定义，还有各种缩进、语法问题，看着简直折磨人
大佬能帮忙完善一下吗？{:1_9:} 谢谢分享！~~~~~~~ 谢谢分享谢谢分享谢谢分享谢谢分享谢谢分享 好梦压星河啊 发表于 2021-3-18 13:49
大佬能帮忙完善一下吗？
楼主平时绘图的单位是0.1以下的吗？注释上说了小于0.2会导致修剪不准确，不要随意修改。除非你的绘图单位很小
(defun dd (x / zc obj et st snew k dx)
(setq obj (vlax-ename->vla-object x))
(setq zc (vlax-curve-getdistatparam ;;长度
obj
(vlax-curve-getendparam obj)
)
)
(setq et (trans (vlax-curve-getEndPoint obj) 0 1)
st (trans (vlax-curve-getStartPoint obj) 0 1)
)
(cond
((= dx0 "LINE")
(setq plist (append (list st et)))
)
((= dx0 "LWPOLYLINE")
(mapcar '(lambda (x)
(if (= (car x) 10)
(setq plist (cons (trans (cdr x) 0 1) plist))
)
)
(entget en)
)
(if(= 1 (dxf 70 x))(setq plist (append plist (list (car plist)))))
)
((or (= dx0 "SPLINE")(= dx0 "CIRCLE")(= dx0 "ELLIPSE"))
(setq zc (fix zc) k 0)
(command "_.divide" x zc)
(setq snew (ssget "p"))
(repeat (sslength snew)
(setq s (ssname snew k))
(setq dx (dxf 10 s))
(setq plist (cons (trans (cdr dx) 0 1) plist))
(setq k (1+ k))
)
(command "erase" snew "")
(setq plist(reverse plist))
(if (/= dx0 "SPLINE")
(setq plist (appendplist (list et)))
(setq plist (append (list st) plist (list et)))
)
)
)
(entdel x)
plist
)把函数dd用以上替换一下，解决用户坐标系不能用的问题
(command ".offset" (* 0.001 (getvar "viewsize")) e1 po "")用以上代码替换下面一行，解决小于0.2会无法裁剪问题
(command ".offset" 0.2 e1 po "")
希望多多参与回帖，对帖主鼓励的同时自己还能获得币 做一个快乐学习的人 本帖最后由 好梦压星河啊 于 2021-3-19 14:40 编辑
hbwr123 发表于 2021-3-19 09:11
楼主平时绘图的单位是0.1以下的吗？注释上说了小于0.2会导致修剪不准确，不要随意修改。除非你的绘图单 ...
非常感谢大佬帮助，我刚刚试了一下，两个问题都已经解决，但是我发现了一个新的问题，就是如果使用该插件期间，按esc退出的话，会导致捕捉设置失效，原插件最后有(setvar "osmode" 487) ，但中途退出不生效，有什么好的解决办法吗？ 本帖最后由 hbwr123 于 2021-3-20 15:31 编辑
好梦压星河啊 发表于 2021-3-19 14:00
非常感谢大佬帮助，我刚刚试了一下，两个问题都已经解决，但是我发现了一个新的问题，就是如果使用该插件 ...
在(defun c:tt(/ PO SS I J S1 P1 P2 )下一行插入以下代码：(defun tt:error(msg)
(setq *error* olderror olderror nil)
(command "undo" "e")
(setvar 'cmdecho 1)
(setvar 'osmode osvalue)
(princ msg)
)
(setq olderror *error* *error* tt:error)
并且把函数c:tt最后的
(setvar 'osmode 1)
改为
(setvar 'osmode osvalue)
页:
[1]
2