智能修剪 改进
这是论坛里一个大大的程序当我看见这程序非常喜欢但遗憾的是不支持PL线 还有圆弧线
请大大 版主们帮忙改改 谢谢
让他支持 PL线 圆弧线
本帖最后由 sroo 于 2017-8-24 23:25 编辑
好厉害！:hug:
6楼代码好长。不过cad2006以上的版本输入剪切命令trim，按两下空格键，好像也可以实现吧，即
(defun c : Q() (command "TRIM") (command "") (princ "修剪Q") (princ)) 我工作中 碰不到这种 案例 下載學習，謝謝版主! 可以上个动画吗？请问和EXTRIM有何区别？ trim再输入f就可以修剪多段线，圆弧。按照这个编写程序 荒野孤行 发表于 2014-6-15 11:11 static/image/common/back.gif
trim再输入f就可以修剪多段线，圆弧。按照这个编写程序
大哥 能帮我把程序改改吗？？？？ love1030312 发表于 2014-6-15 16:35 static/image/common/back.gif
大哥 能帮我把程序改改吗？？？？
论坛上已经有人发过了，直接找下就好了 估计论坛应该有完美解决的版本吧，我倒是有个凑合的程序
声明觉非原创。略加修改。
只能实现框选修剪，对于多段线，并不能完美处理。
闭合多段线得点再来一次，另外多段线的修剪后有的会是散的。。
暂时不打算深入研究
你在论坛继续找找吧，不过还得吐槽论坛的搜索功能，感觉搜索功能不是很理想。。。有的压根搜索不到。。
以下是代码，再次申明，非原创。
;;;=======================[ BreakObjects.lsp ]==============================
;;; Author: Copyright?2006,2007 Charles Alan Butler
;;; Contact @www.TheSwamp.org
;;; Version:1.3 April 9,2007
;;; Globalization by XANADU - www.xanadu.cz
;;; Purpose: Break All selected objects
;;; permitted objects are lines, lwplines, plines, splines,
;;; ellipse, circles & arcs
;;;
;;;Functionc:BreakAll - Break all objects selected
;;;Functionc:BreakwObjects - Break many objects with a single object
;;;Functionc:BreakObject - Break a single object with many objects
;;;Functionc:BreakWith - Break selected objects with other selected objects
;;;Functionc:BreakTouching - Break objects touching the single Break object
;;;Functionc:BreakSelected - Break selected objects with anyobjects that touch it
;;;
;;; Sub_Routines:
;;; break_with
;;; ssget->vla-list
;;; list->3pair
;;; onlockedlayer
;;; get_interpts Return a list of intersect points
;;; break_objBreak entity at break points in list
;;; Requirements: objects must have the same z-value
;;; Restrictions: Does not Break objects on locked layers
;;; Returns:none
;;;=====================================================================
;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED ;
;;; WARRANTY.ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR ;
;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED. ;
;;; ;
;;;You are hereby granted permission to use, copy and modify this ;
;;;software without charge, provided you do so exclusively for ;
;;;your own use or for use by others in your organization in the ;
;;;performance of their normal duties, and provided further that ;
;;;the above copyright notice appears in all copies and both that ;
;;;copyright notice and the limited warranty and restricted rights;
;;;notice below appear in all supporting documentation. ;
;;;=====================================================================
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; M A I N S U B R O U T I N E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;打断对象，隔断对象，自断
(defun NBTF_break_with (ss2brk ss2brkwith self
/ cmd intpts
lst masterlist ss
ssobjs onlockedlayer
ssget->vla-list list->3pair
get_interpts break_obj
)
;; ss2brk selection set to break
;; ss2brkwith selection set to use as break points
;; self when true will allow an object to break itself
;; note that plined will break at each vertex
(vl-load-com)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(defun onlockedlayer (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)
(defun ssget->vla-list (ss / i ename lst)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq lst (cons (vlax-ename->vla-object ename) lst))
)
lst
)
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old)
)
)
(reverse new)
)
;;==============================================================
;;return a list of intersect points
;;==============================================================
(defun get_interpts (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq
iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone)
)
)
)
)
)
)
iplist
)
)
;;==============================================================
;;Break entity at break points in list
;;==============================================================
(defun break_obj (ent brkptlst / brkobjlst
en enttype maxparam closedobj
minparam obj obj2breakp1param
p2 p2param
)
(setq obj2break ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
)
(foreach brkpt brkptlst
;;get last entity created via break in case multiple breaks
(if brkobjlst
(progn
;;if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj2break brkpt)
)
)
)
(foreach obj brkobjlst ; find the one that pt is on
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint
(list obj brkpt)
)
)
(setq obj2break obj) ; switch objects
)
)
)
)
)
;;Handle any objects that can not be used with the Break Command
;;using one point, gap of 0.000001 is used
(cond
((and (= "SPLINE" enttype) ; only closed splines
(vlax-curve-isclosed obj2break)
)
(setq p1param (vlax-curve-getparamatpoint obj2break brkpt)
p2 (vlax-curve-getpointatparam
obj2break
(+ p1param 0.000001)
)
)
(command "._break"
obj2break
"_non"
(trans brkpt 0 1)
"_non"
(trans p2 0 1)
)
)
((= "CIRCLE" enttype) ; break the circle
(setq p1param (vlax-curve-getparamatpoint obj2break brkpt)
p2 (vlax-curve-getpointatparam
obj2break
(+ p1param 0.000001)
)
)
(command "._break"
obj2break
"_non"
(trans brkpt 0 1)
"_non"
(trans p2 0 1)
)
(setq enttype "ARC")
)
((and (= "ELLIPSE" enttype) ; only closed ellipse
(vlax-curve-isclosed obj2break)
)
;;Break the ellipse, code borrowed from Joe Burke6/6/2005
(setq p1param (vlax-curve-getparamatpoint obj2break brkpt)
p2param (+ p1param 0.000001)
minparam (min p1param p2param)
maxparam (max p1param p2param)
obj (vlax-ename->vla-object obj2break)
)
(vlax-put obj 'startparameter maxparam)
(vlax-put obj 'endparameter (+ minparam (* pi 2)))
)
;;==================================
(t ; Objects that can be broken
(setq closedobj (vlax-curve-isclosed obj2break))
(command "._break"
obj2break
"_non"
(trans brkpt 0 1)
"_non"
(trans brkpt 0 1)
)
(if (not closedobj) ; new object was created
(setq brkobjlst (cons (entlast) brkobjlst))
)
)
)
)
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(if (and ss2brk ss2brkwith)
(progn
;;CREATE a list of entity & it's break points
(foreach obj (ssget->vla-list ss2brk)
; check each object in ss2brk
(if (not (onlockedlayer (vlax-vla-object->ename obj)))
(progn
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(foreach intobj (ssget->vla-list ss2brkwith)
(if (and (or self (not (equal obj intobj)))
(setq intpts (get_interpts obj intobj))
)
(setq lst (append (list->3pair intpts) lst))
; entity w/ break points
)
)
(if lst
(setq masterlist
(cons (cons (vlax-vla-object->ename obj) lst)
masterlist
)
)
)
)
)
)
;;masterlist = ((ent brkpts)(ent brkpts)...)
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk))
)
)
)
)
;;==============================================================
)
;;==========================================================
;;选择对象被图中对象打断
;;==========================================================
;(defun c:BreakSelected (/ cmd ss1 ss2)
(defun c:tt (/ cmd ss1 ss2)
;;get all objects touching entities in the sscross
;;limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
(defun gettouching (sscros / ss lst lstb lstc objl)
(and
(setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
objl (mapcar 'vlax-ename->vla-object lstb)
)
(setq
ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))))
)
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(mapcar
'(lambda (y)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith y x acextendnone)
))))))
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
) objl)
) lst)
)
lstc
)
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "._undo" "_begin")
;;get objects to break
(while(and (setq p1(getpoint "\n指定第一点:"))
(setq p3(getcorner p1 "\n指定第二点:"))
)
(setq ss1 (ssadd))
(if (and ;(not (prompt "\n(选择对象被图中对象打断)选择需要打断的对象<退出>: "))
(setq ss2 (ssget "c" p1 p3 '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(progn
(NBTF_break_with ss2 ss1 nil); ss2break ss2breakwith (flag nil = not to break with self)
(if(setq ss3(ssget "w" p1 p3 '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(command "_.ERASE" ss3"")
)
)
)
)
(command "._undo" "_end")
(setvar "CMDECHO" cmd)
(princ)
)
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
;; E n d O f F i l e I f y o u A r e H e r e
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
大大 你 说话太经典了都是我的心声啊 感谢大大 edata 发表于 2014-6-16 22:05 static/image/common/back.gif
估计论坛应该有完美解决的版本吧，我倒是有个凑合的程序
声明觉非原创。略加修改。
只能实现框选修剪，对 ...
大大 你 说话太经典了都是我的心声啊 感谢大大 edata 发表于 2014-6-16 22:05 static/image/common/back.gif
估计论坛应该有完美解决的版本吧，我倒是有个凑合的程序
声明觉非原创。略加修改。
只能实现框选修剪，对 ...
大大 圆角部分怎么没有了 为什么不能下载？
页:
[1]
2