求一个特殊的“合并多段线”lisp
效果就如图中所示，多段线1可能是封闭的，也可能是不封闭的。多断线2和多段线1有两个交点。我希望实现的功能是，把多段线1删除掉两个交点之间的部分，然后剩下的部分和多段线1合并（join命令）。
还有就是多段线1和多段线2之间可能有微小的间隙，并没有实际相交，最好能给一个模糊距离的判定，类似于pedit命令中合并多段线的那种。
有大神能解决的，我充值10个明经币悬赏给他，以表示我的感激之情！
;;重合打断消重
其实也简单得爆，全部炸开，直线从短到长，排序。从头遍历，找到重合的就用长直线减短直线留下剩下的，短的就一并丢掉。至于重合，一个trans把直线搞成加减法就搞定了 xyp1964 发表于 2015-11-21 04:31
;;重合打断消重
经典经典，院长大人能否贴上码，厉害了 ;;-----------------------=={ Outline Objects}==-----------------------;;
;; ;;
;;This program enables the user to generate one or more closed ;;
;;polylines or regions outlining all objects in a selection. ;;
;; ;;
;;Following a valid selection, the program calculates the overall ;;
;;rectangular extents of all selected objects and constructs a ;;
;;temporary rectangular polyline offset outside of such extents. ;;
;; ;;
;;Using a point located within the offset margin between the extents;;
;;of the selection and temporary rectangular frame, the program then;;
;;leverages the standard AutoCAD BOUNDARY command to construct ;;
;;polylines and/or regions surrounding all 'islands' within the ;;
;;temporary bounding frame. ;;
;; ;;
;;----------------------------------------------------------------------;;
;;Author:Lee Mac, Copyright ?2014-www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;;Version 1.0 - 2014-11-30 ;;
;; ;;
;;First release. ;;
;;----------------------------------------------------------------------;;
(defun c:outline ( / *error* sel )
(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(if (setq sel (ssget))
(progn
(LM:startundo (LM:acdoc))
(LM:outline sel)
(LM:endundo (LM:acdoc))
)
)
(princ)
)
;; Outline Objects-Lee Mac
;; Attempts to generate a polyline outlining the selected objects.
;; sel - Selection Set to outline
;; Returns: A selection set of all objects created
(defun LM:outline ( sel / app are box cmd dis enl ent lst obj rtn tmp )
(if (setq box (LM:ssboundingbox sel))
(progn
(setq app (vlax-get-acad-object)
dis (/ (apply 'distance box) 20.0)
lst (mapcar '(lambda ( a o ) (mapcar o a (list dis dis))) box '(- +))
are (apply '* (apply 'mapcar (cons '- (reverse lst))))
dis (* dis 1.5)
ent
(entmakex
(append
'( (000 . "LWPOLYLINE")
(100 . "AcDbEntity")
(100 . "AcDbPolyline")
(090 . 4)
(070 . 1)
)
(mapcar '(lambda ( x ) (cons 10 (mapcar '(lambda ( y ) ((eval y) lst)) x)))
'( (caar cadar)
(caadrcadar)
(caadr cadadr)
(caarcadadr)
)
)
)
)
)
(apply 'vlax-invoke
(vl-list* app 'zoomwindow
(mapcar '(lambda ( a o ) (mapcar o a (list dis dis 0.0))) box '(- +))
)
)
(setq cmd (getvar 'cmdecho)
enl (entlast)
rtn (ssadd)
)
(while (setq tmp (entnext enl)) (setq enl tmp))
(setvar 'cmdecho 0)
(command
"_.-boundary" "_a" "_b" "_n" sel ent "" "_i" "_y" "_o" "_p" "" "_non"
(trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0))) 0 1) ""
)
(while (< 0 (getvar 'cmdactive)) (command ""))
(entdel ent)
(while (setq enl (entnext enl))
(if (and (vlax-property-available-p (setq obj (vlax-ename->vla-object enl)) 'area)
(equal (vla-get-area obj) are 1e-4)
)
(entdel enl)
(ssaddenl rtn)
)
)
(vla-zoomprevious app)
(setvar 'cmdecho cmd)
rtn
)
)
)
;; Selection Set Bounding Box-Lee Mac
;; Returns a list of the lower-left and upper-right WCS coordinates of a
;; rectangular frame bounding all objects in a supplied selection set.
;; s - Selection set for which to return bounding box
(defun LM:ssboundingbox ( s / a b i m n o )
(repeat (setq i (sslength s))
(if
(and
(setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
(vlax-method-applicable-p o 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
)
(setq m (cons (vlax-safearray->list a) m)
n (cons (vlax-safearray->list b) n)
)
)
)
(if (and m n)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
)
)
;; Start Undo-Lee Mac
;; Opens an Undo Group.
(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)
;; End Undo-Lee Mac
;; Closes an Undo Group.
(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)
;; Active Document-Lee Mac
;; Returns the VLA Active Document Object
(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)
(vl-load-com) (princ)
;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;; brbright 发表于 2015-11-18 12:53 static/image/common/back.gif
;;-----------------------=={ Outline Objects}==-----------------------;;
;; ...
非常感谢，我在程序的末尾自行加了一句(command "erase" sel "")
对应左边的图形来说除了模糊距离设置外几乎是完美的。但是对右边的图形，就达不到理想的效果了。
貌似程序只能针对“外扩”的情况，不能用于“内缩”啊。
你贴出来的程序是生成轮廓线，当然不能内凹了。
如果是封闭多义线，可考虑转换为面域然后求并集、差集等操作再转换为多义线。 qetuop 发表于 2015-11-18 14:17 static/image/common/back.gif
非常感谢，我在程序的末尾自行加了一句(command "erase" sel "")
对应左边的图形来说除了模糊距离设置 ...
http://bbs.mjtd.com/thread-170194-1-1.html
你看看这个，我在国外找的。
http://autocadtips1.com/2012/02/28/autolisp-subract-objects-from-a-closed-polyline/ brbright 发表于 2015-11-18 16:25 static/image/common/back.gif
http://bbs.mjtd.com/thread-170194-1-1.html
你看看这个，我在国外找的。
好吧，还是有一定的局限性，不知道还有没有其他大神能出手的。 针对ＬＺ例举的两种情况，只需要短的多段线两端点之间剪切，然后合并段线，这样程序就简单多了。 自贡黄明儒 发表于 2015-11-19 08:17 static/image/common/back.gif
针对ＬＺ例举的两种情况，只需要短的多段线两端点之间剪切，然后合并段线，这样程序就简单多了。
小弟新手，能力有限，只会一些简单的command命令，大神可否给一个完整的代码，感激不尽！ ;边界轮廓线
(defun c:bjlkx ()
(setvar "CMDECHO" 0)
(if (and (setq p1 (getpoint "\n第一角点: "))
(setq p2 (getcorner p1 "\n另一角点: "))) (progn
(setq s1 (entlast))
(command "_.RECTANG" p1 p2)
(setq p3 (polar p1 (angle p1 p2) 5));;;数字5设置跟图形大小有关，如图形较大可设置100或1000
(command "_.BOUNDARY" p3 "")
(command "_.ERASE" "C" p1 p1 "")
(setq ss (ssadd))
(while (setq s1 (entnext s1)) (ssadd s1 ss))
(if (> (sslength ss) 0)
(command "_.ERASE" "W" p1 p2 "R" ss "")
(princ "\n无法生成边界！")
)
))
(setvar "CMDECHO" 1)
(princ)
)
;;;
(vl-load-com)
(defun c:fzbf(/ oo st_pt end_pt pt1 pt2 pt_tmp l_ss)
(setq oo (entsel "请选择线上第一个点"))
(setq ss (car oo))
(setq pt1 (osnap (cadr oo) "near"))
(setq st_pt (vlax-curve-getStartPoint ss)
end_pt (vlax-curve-getEndPoint ss)
pt2 (getpoint "线上第二个点")
)
(if (>(vlax-curve-getParamAtPoint ss pt1) (vlax-curve-getParamAtPoint ss pt2))
(setq pt_tmp pt2
pt2 pt1
pt1 pt_tmp)
)
(command "undo" "be")
(command "_break" ss st_pt pt1)
(command "_break" ss end_pt pt2)
(command ".copy" ss "" '(0 0) '(0 0))
(setq l_ss (entget (entlast)))
(command "undo" "end")
(command "undo" "")
(entmake l_ss)
(setq ss (entlast))
(vla-put-Color (vlax-ename->vla-object ss) 1)
(command "_move"ss "" pt1 )
) 香田里浪人 发表于 2015-11-19 21:24 static/image/common/back.gif
;边界轮廓线
(defun c:bjlkx ()
(setvar "CMDECHO" 0)
大哥的程序好像只是拉出轮廓的一部分啊
页:
[1]
2