[wkq004]按多边形范围裁切,裁内,裁外,裁搭界...
本帖最后由 004 于 2012-12-20 23:33 编辑用"裁切"搜索论坛相关的源码仅有3篇,一片是 xgr 写的局部复制的,还有一篇是裁外的,是半成品,而最后一片是半成品的简化版.好惨啊,但事实就是这样.我写的这个仅实现了裁内,裁外两个功能,有时还会出错,请大侠指点,有能力了加强到仿MicroStation---fance的效果,那就完结了.
还有看到高手老说扩展的acet函数,但代码看着真晕,哪位大侠把学习这些源码的经历,分享下,要怎么学.
(defun c:tt (/ AA E EL ELONG EN EO EPTL FX I LEN LST OLDBLIP OLDCMD OLDGROUP OLDPDMODE OLDSNAP OLONG
ONE PT PTL PTLST PXMAX SS SSTEXT TEXT
)
;;功能:选择范围和方向点,裁内或裁外
;;局限:1.仅支持轻多段线范围,2.范围线不能打折
;;日期:wkq004@qq.com修改 2012-12-20
;;原程序来自明经通道by xgr 2007-8-30
(command ".undo" "e")
(command ".undo" "begin")
(setvar "LUPREC" 8)
(setq oldgroup (getvar "pickstyle")) ;保存编组开关
(setvar "pickstyle" 0) ;关闭编组
(setq oldcmd (getvar "cmdecho")) ;保存控制 command 函数运行期间，AutoCAD 是否回显提示和输入
(setvar "cmdecho" 0) ;关闭command 函数运行期间，AutoCAD 回显提示和输入
(setq oldblip (getvar "blipmode")) ;保存控制点标记
(setvar "blipmode" 0) ;关闭点标记
(setq oldpdmode (getvar "pdmode")) ;关闭点样式
(setq oldsnap (getvar "osmode")) ;保存对象捕捉方式
(setvar "osmode" 0) ;关闭对象捕捉式
(while (or (if (setq en (nentselp "\n选择作为剪切边界的闭合多段线:"))
nil
(setq ss "空选择!")
)
(if (= (cdr (assoc 0 (setq el (entget (setq e (car en)))))) "LWPOLYLINE")
nil
(setq ss "类型错误!")
)
(if (= (logand (cdr (assoc 70 el)) 1) 1)
nil
(setq ss "线段不闭合!")
)
(if (setq fx (getpoint "\n请选择裁切方向:"))
nil
(setq ss "选择裁切方向!")
)
)
(alert (strcat "选择错误-" ss ",重新选择!"))
)
(setq elong 0)
(setq eptl '())
(setq one (cdr (assoc 10 el)))
(foreach pt el
(if (= 10 (car pt))
(setq pt (cdr pt)
elong (+ elong (distance one pt))
one pt
eptl(cons pt eptl)
)
)
)
(print "\n正在剪切图形,请稍侯......")
(command ".offset" 0.1 e fx "");_原多段线上有重点,偏移后的线上应该没有重点吧?
(setq eo (entlast))
(setq el (entget eo))
(command ".erase" eo "")
(setq olong 0)
(setq ptl '())
(setq one (cdr (assoc 10 el)))
(foreach pt el
(if (= 10 (car pt))
(setq pt (cdr pt)
olong (+ olong (distance one pt))
one pt
ptl (cons pt ptl)
)
)
)
(setq pxmax (list (apply 'mapcar (cons 'min ptl)) (apply 'mapcar (cons 'max ptl))))
(command ".zoom" "w" (car pxmax) (cadr pxmax))
(setq ptl (append ptl (list (car ptl))))
;;炸开相交的块,面域,填充图案
(setq i 0)
(while (and (setq ss (ssget "F" ptl '((0 . "INSERT,HATCH,REGION")))) (> 10000 (setq i (1+ i))))
(repeat (setq len (sslength ss)) (command ".EXPLODE" (ssname ss (setq len (1- len)))))
)
(setvar "pdmode" 0) ;_关闭点样式
(setq lst '())
(if (setq ss (ssget "f" ptl '((0 . "text,mtext"))))
(repeat (setq len (sslength ss))
(setq text (ssname ss (setq len (1- len))))
(setq pt (assoc 10 (entget text)))
(entmake (list '(0 . "point") pt))
(setq lst (cons (list (entlast) text) lst))
)
)
;;偏移线的长度小于原线长度,裁内否则裁外
(if (< olong elong)
;;裁内
(if (setq ss (ssget "wp" eptl))
(command ".erase" ss "")
)
;;裁外
(if (setq ss (ssget "cp" eptl))
(command ".erase" "all" "r" ss "")
)
)
(foreach potx lst
(if (entget (car potx))
(entdel (car potx))
(entdel (cadr potx))
)
)
(repeat 3
(setq one (car ptl))
(foreach two (cdr ptl) (command ".trim" e "" "f" one two "" "") (setq one two))
)
;;删除向内裁切矩形的对角线,考虑文本
;;处理有宽度的多段线
(if (setq ss (ssget "cp"
ptl
'((-4 . "<NOT")
(-4 . "<or")
(0 . "text,mtext,INSERT,HATCH,REGION")
(-4 . "<and")
(0 . "lwpolyline,polyline")
(-4 . "<or")
(-4 . ">")
(40 . 0.0)
(-4 . ">")
(41 . 0.0)
(-4 . "or>")
(-4 . "and>")
(-4 . "or>")
(-4 . "NOT>")
)
)
)
(if (< olong elong)
;;裁内
(command ".erase" ss "")
;;裁外
(command ".erase" "all" "r" ss "")
)
)
(command "zoom" "p") ;_恢复视窗大小
(setvar "LUPREC" 8)
(setvar "pickstyle" oldgroup)
(setvar "cmdecho" oldcmd)
(setvar "blipmode" oldblip)
(setvar "pdmode" oldpdmode)
(setvar "osmode" oldsnap)
(command ".undo" "e")
(princ)
)
本帖最后由 zzc83 于 2012-12-21 07:35 编辑
[资源] 求删除封闭多边形内部所有图元的lsp？送一个删除外部图元的lsp http://bbs.mjtd.com/thread-85904-2-1.html 如果内部的可以多选就好 谢谢，正是我想要的，看来搜索还得用多个相近关键字，写之前先问问的好。 如果可以局部复制就好了，，， 好像还是有点问题，
*无效*
程序出错！返回到起始状态。 mycad 发表于 2013-3-30 13:20 static/image/common/back.gif
好像还是有点问题，
*无效*
程序出错！返回到起始状态。
目前为止最好的裁切源码
http://bbs.mjtd.com/thread-85904-2-1.html 都是高手，学习了 好像对于宽度不为0的多段线不管用。 都是高手，学习了
页:
[1]
2