马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。
您需要 登录 才可以下载或查看，没有账号？立即注册
×
(defun c:joinlines23dpolys (/ *error* _vl-position uniquechain adoc ss ti
elst e e1 ee eg egg entl pl p pp f chainl
vertl vts tmp
)
(vl-load-com)
(defun *error* (m)
(vla-endundomark adoc)
(if m
(prompt m)
)
(princ)
) ; (_vl-position 3.29 '(1.1 2.2 3.3
; 4.4 5.5 6.6 7.7 8.8 9.9) 0.01 nil)
; => 2 (!k => nil) ;;
(defun _vl-position (e l tol k)
(if (null k)
(setq k 0)
)
(if (not (equal e (car l) tol))
(progn
(setq k (1+ k))
(if (cdr l)
(_vl-position e (cdr l) tol k)
(setq k nil)
)
)
k
)
)
(defun uniquechain (l)
(if l
(cons (car l) (uniquechain (vl-remove-if '(lambda (x)
(or
(and
(equal (caar l)
(car x) 1e-6
)
(equal (cadar l)
(cadr x) 1e-6
)
)
(and
(equal (caar l)
(cadr x) 1e-6
)
(equal (cadar l)
(car x) 1e-6
)
)
)
) l
)
)
)
)
)
(vla-startundomark (setq adoc (vla-get-activedocument
(vlax-get-acad-object)
)
)
)
(setq ss (ssget "_:L" '((0 . "LINE"))))
(setq ti (car (_vl-times)))
(setq elst (vl-remove-if 'listp (mapcar
'cadr
(ssnamex ss)
)
)
)
(setq entl (mapcar
'(lambda (x)
(list (vlax-curve-getstartpoint x)
(vlax-curve-getendpoint x) x
)
)
elst
)
)
(setq entl (uniquechain entl))
(foreach e elst
(entdel e)
)
(setq elst (mapcar
'caddr
entl
)
)
(foreach e elst
(entdel e)
)
(while (or
ee
(setq e (car elst)
e1 e
)
)
(if (vl-some '(lambda (x)
(or
(equal (vlax-curve-getstartpoint e)
(vlax-curve-getstartpoint x) 1e-6
)
(equal (vlax-curve-getstartpoint e)
(vlax-curve-getendpoint x) 1e-6
)
(equal (vlax-curve-getendpoint e)
(vlax-curve-getstartpoint x) 1e-6
)
(equal (vlax-curve-getendpoint e)
(vlax-curve-getendpoint x) 1e-6
)
)
) (setq tmp (vl-remove e elst))
)
(cond
((vl-some '(lambda (x)
(if (equal (vlax-curve-getstartpoint e)
(vlax-curve-getstartpoint x) 1e-6
)
(setq ee x)
(setq ee nil)
)
) tmp
)
(if (not (vl-position e eg))
(setq eg (cons e eg))
)
)
((vl-some '(lambda (x)
(if (equal (vlax-curve-getstartpoint e)
(vlax-curve-getendpoint x) 1e-6
)
(setq ee x)
(setq ee nil)
)
) tmp
)
(if (not (vl-position e eg))
(setq eg (cons e eg))
)
)
((vl-some '(lambda (x)
(if (equal (vlax-curve-getendpoint e)
(vlax-curve-getstartpoint x) 1e-6
)
(setq ee x)
(setq ee nil)
)
) tmp
)
(if (not (vl-position e eg))
(setq eg (cons e eg))
)
)
((vl-some '(lambda (x)
(if (equal (vlax-curve-getendpoint e)
(vlax-curve-getendpoint x) 1e-6
)
(setq ee x)
(setq ee nil)
)
) tmp
)
(if (not (vl-position e eg))
(setq eg (cons e eg))
)
)
)
(if (null eg)
(setq eg (cons e eg)
egg (cons eg egg)
ee nil
eg nil
f nil
)
(if (null f)
(progn
(if (not (vl-position e eg))
(setq eg (cons e eg))
)
(setq ee e1
f t
)
)
(progn
(if (not (vl-position e eg))
(setq eg (cons e eg))
)
(setq ee nil
egg (cons eg egg)
eg nil
f nil
)
)
)
)
)
(setq elst (vl-remove e elst))
(if ee
(setq e ee)
)
)
(foreach eg egg
(if (/= (length eg) 1)
(while (> (length eg) 1)
(setq pp nil
f nil
)
(setq entl (mapcar
'(lambda (x)
(list (vlax-curve-getstartpoint x)
(vlax-curve-getendpoint x) x
)
)
eg
)
)
(setq pl (vl-remove-if '(lambda (x)
(= (type x) 'ENAME)
) (apply
'append
entl
)
)
)
(while (setq p (car pl))
(if (_vl-position p (cdr pl) 1e-6 nil)
(setq pl (vl-remove-if '(lambda (x)
(equal p x 1e-6)
) pl
)
)
(setq pp p
pl (cdr pl)
)
)
)
(if pp
(setq e (vl-some '(lambda (x)
(if (or
(equal (car x) pp 1e-6)
(equal (cadr x) pp 1e-6)
)
x
)
) entl
)
)
(setq e (car entl))
)
(while e
(setq chainl (cons e chainl))
(setq e (vl-some '(lambda (x)
(cond
((and
pp
(= (length chainl) 1)
)
(if (equal (car e) pp 1e-6)
(cond
((equal (cadr e) (car x) 1e-6)
(setq f t)
x
)
((equal (cadr e) (cadr x) 1e-6)
(setq f nil)
x
)
)
(cond
((equal (car e) (car x) 1e-6)
(setq f t)
x
)
((equal (car e) (cadr x) 1e-6)
(setq f nil)
x
)
)
)
)
((= (length chainl) 1)
(cond
((equal (cadr e) (car x) 1e-6)
(setq f t)
x
)
((equal (cadr e) (cadr x) 1e-6)
(setq f nil)
x
)
)
)
(t
(cond
((and
f
(equal (cadr e) (car x) 1e-6)
)
(setq f t)
x
)
((and
f
(equal (cadr e) (cadr x) 1e-6)
)
(setq f nil)
x
)
((and
(null f)
(equal (car e) (car x) 1e-6)
)
(setq f t)
x
)
((and
(null f)
(equal (car e) (cadr x) 1e-6)
)
(setq f nil)
x
)
)
)
)
) (setq entl (vl-remove e entl))
)
)
)
(setq chainl (reverse chainl))
(if pp
(setq vertl (append
(list (if (equal (caar chainl) pp 1e-6)
(caar chainl)
(cadar chainl)
)
)
(setq vts (mapcar
'(lambda (a b)
(cond
((equal (car a) (car b) 1e-6)
(car a)
)
((equal (car a) (cadr b) 1e-6)
(car a)
)
((equal (cadr a) (car b) 1e-6)
(cadr a)
)
((equal (cadr a) (cadr b) 1e-6)
(cadr a)
)
)
)
chainl
(cdr chainl)
)
)
(vl-remove-if '(lambda (x)
(equal x (last vts) 1e-6)
) (vl-remove-if '(lambda (x)
(= (type x) 'ENAME)
) (last chainl)
)
)
)
)
(setq vertl (append
(list (caar chainl))
(mapcar
'(lambda (a b)
(cond
((equal (car a) (car b) 1e-6)
(car a)
)
((equal (car a) (cadr b) 1e-6)
(car a)
)
((equal (cadr a) (car b) 1e-6)
(cadr a)
)
((equal (cadr a) (cadr b) 1e-6)
(cadr a)
)
)
)
chainl
(cdr chainl)
)
)
)
)
(foreach chain chainl
(setq eg (vl-remove (caddr chain) eg))
(entdel (caddr chain))
)
(setq chainl nil)
(if (car vertl)
(progn
(entmake (list '(0 . "POLYLINE") '(100 . "AcDbEntity") '
(100 . "AcDb3dPolyline") '(66 . 1) '(10 0.0 0.0
0.0
)
(if pp
(cons 70 8)
(cons 70 9)
) '(210 0.0 0.0 1.0)
)
)
(foreach pt vertl
(entmake (list '(0 . "VERTEX") '(100 . "AcDbEntity") '
(100 . "AcDbVertex") '(100 . "AcDb3dPolylineVertex")
(cons 10 pt) '(70 . 32)
)
)
)
(entmake (list '(0 . "SEQEND") '(100 . "AcDbEntity")))
)
)
(setq vertl nil)
)
)
)
(prompt "\nElapsed time : ")
(princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 20))
(prompt " seconds...")
(*error* nil)
)
| 
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园
( 辽ICP备15016793号 )
窥视卡
雷达卡
已领礼包: 
财富等级: 
发表于 2016-12-13 13:41:29
提升卡
置顶卡
沉默卡
变色卡
千斤顶
