修剪命令的增强版
在网上看到的修剪代码在实际使用上还是不理想 。此代码的功能是选择闭合的多段线：点击多段线内侧，则内侧的线修剪：点击外侧，则外侧修剪：选择直线时，点击直线的哪一侧，哪一侧就会修剪。 现在我想能此功能可不可以增加个选择两根直线则两根直线内的线就会修剪 。我发代码发上来，希望哪位完善下这个功能，还有个问题就是此命令使用的时候，对象捕捉的设置点都没有了，;;可点可框的修剪
(defun c:tt (/ PO SS I J S1 P1 P2 p3 p4 lene1 e1co pt0 fs g z ptcode_12)
(vl-load-com)
(setq osvalue (getvar "osmode"))
(setq cm(GETVAR "CMDECHO") os(getvar "osmode"))
(SETVAR "CMDECHO" 0)
(setvar "osmode" 0)
(setq plist NIL lst nil new nil ss nil ennil 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))
(setq box (* (/ (getvar "pickbox") (cadr (getvar "screensize")))
(getvar "viewsize")));取当前拾取盒宽
(setq box(* 0.5 box));取当前拾取盒宽的0.5倍作为偏移值
(setq e1co (entget e1));;保存实体数据
(command ".offset" box e1 po "")
(setq en(entlast) dx0(dxf 0 e1))
(if po
(setq plist(dingd en));; 求顶点表
)
(command "trim" S1 "")
(repeat 5
(COMMAND "f")
(apply 'command plist)
(COMMAND "")
)
(COMMAND "")
(command "erase" e1 "");;删除修剪后的修剪线
(entmake e1co);;防止剪掉自己生成一个和原来一样的线
)
((> len 1);;;;;;;;;;如果是多选
(prompt"\n请选择修剪方式<F栏选/左击移动/右击框选>:")
(setq code_12 (grread (setq code (grread))));将类型代码 12 的数据从缓冲区中清除
(initget 128)
(setq g(grread nil 4 0) fs(car g))
(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 "")
)
((MEMBER (cadr g) '(70 102));;;如果选f
(setvar 'cmdecho 1)
(command "trim" s1 "" "f")
(while(/= 0 (getvar "cmdactive"))(command PAUSE))
(setvar 'cmdecho 0)
)
((member (cadr g) '(0 13 32));;;如果是右击或空格或回车
(setq p1 (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);;如果没有选择
(setvar 'cmdecho 1)
(command ".trim" "")
(while(/= 0 (getvar "cmdactive"))(command PAUSE))
(setvar 'cmdecho 0)
)
);;;;;;;;;;;;;;;;;;;;
(command "undo" "e")
(setvar 'cmdecho cm)
(setvar 'osmode os)
(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 pt0 pt
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 dingd (x / et st)
(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))))
((or(= dx0 "LWPOLYLINE")(= dx0 "POLYLINE"))
(setq dx90(dxf 90 en))
(setq plist(vxs obj));;多段线另外求
)
((OR(= dx0 "SPLINE")(= dx0 "CIRCLE")(= dx0 "ELLIPSE")(= dx0 "ARC"))
(if (> (fix zc) 0)(setq zc(fix zc))
(setq zc(fix(* 100 zc)))
)
(setq 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
)
;;;;
;;;
;;;
;;;
(defun vxs (e /i j p12 bihe)
(setq i-1 lst nil pn 0 j -1)
(vl-load-com)
;(setq dx90(dxf 90 e));;取顶点数
(setq bihe(vlax-curve-isClosed e));是否闭合
(while (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(if bihe;;如果曲线闭合
(if(and (/= i dx90 )(/= (vla-getbulge e i) 0))
(setqp12 (appendp12 (list v)) pn(1+ pn));提取出现弧度的点放在一起
)
(progn ;;如果曲线不闭合
(if(/= (vla-getbulge e i) 0) ;判断是否有弧度
(setqp12 (appendp12 (list v)) pn(1+ pn));提取出现弧度的点放在一起
)
)
)
(setq lst (appendlst (list v)));不含拟合点的原始点表
)
(repeat pn;;循环弧的次数逐个求出拟合点
(setq j(1+ j))
(setq pa1(nth j p12) pa2(cadr(member pa1 lst)));弧的两个端点
(addpn pa1 pa2);;调用求拟合点函数
(setq lst newlst)
)
lst
)
;;;根据弧的两端点求出其长度
;;;再根据长度求其拟合点
;;;;;;;;求p1-p2之间的拟合点
(defun addpn (p1 p2 / ln ps pe pk pko plt)
(setq newlst nil)
(setq ln (abs (- (vlax-curve-getDistAtPoint obj p2)
;返回曲线从开始点到指定点的曲线段的长度
(vlax-curve-getDistAtPoint obj p1)
)
)
) ;求得p1到p2的长度
(setq ps (vlax-curve-getDistAtPoint obj p1));;开始点到弧起点的长度
(setq pe (vlax-curve-getDistAtPoint obj p2));;开始点到弧端点的长度
(if (= 0 pe)(setq pe zc));;如果长度为0说明与起点重合此时长度应为总长
(setq pk (+ ps 1))
(while (and (> pk ps) (< pk pe));;确保拟合点在弧起始点之间
(setq pko (vlax-curve-getPointAtDist obj pk))
;返回曲线上距开始点为指定距离的点
(setq plt (cons pko plt)) ;求p1-p2之间的拟合点
(setq pk (+ box pk));;用box作为步长
)
(setq plt(reverse plt));;倒置
(foreach n lst
(setq newlst (append newlst (list n)))
(if (and (= (car n) (car p1)) (= (cadr n) (cadr p1)))
(setq newlst (append newlst plt))
;;;在表中指定位置插入拟合点形成新表
)
)
newlst
)
(setvar "osmode" osvalue )
(setvar "ORTHOMODE" 1)
代码的功能如图片
现在问题就是可不可以增加选择两根线两根线内的会裁剪掉， 好想法，先顶着！ 好思路，顶一个。 加载出现：错误: AutoCAD
变量设置被拒绝: "osmode" nil 也会出现：函数已取消 解决 支持下:):) 本帖最后由 dabingrain 于 2013-8-2 10:17 编辑
把里面的 (setvar 'osmode os)改为(setvar "osmode" osvalue )即可解决错误 好程序，值得下载用下！ 本帖最后由 l18c19 于 2013-11-20 11:17 编辑
按照8楼的方法改后，确实能用！ 这个太牛啊了 正需要这样插件 怎么下载呢？木有链接啊，本人是小白 楼主能否将程序改下，我试用了下功能确实强大，但要线与线交点超过一定距离时修剪功能才能用，能否将程序改为只要超出线与线交点，那怕是0.01毫米，修剪功能就能开始修剪呢 好程序如果加入修剪两线内外那就更完美了 谢谢楼主无私分享!!!
页:
[1]
2