连接LINE到3DPOLYLINE

marting · 发表于 2017-7-25 17:10:13

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 newer 于 2017-7-25 17:20 编辑

(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
)
)
(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)
(princ)
)

(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 
    ) 
  ) 
 
  (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) 
  (princ) 
)

函数uniquechain

游客，如果您要查看本帖隐藏内容请回复

q3_2006 · 发表于 2017-7-25 17:15:48

三维用得少..先收下存档..

q3_2006 · 发表于 2017-7-25 17:17:20

函数uniquechain 是乱码..拜托大师重贴一下..谢谢!

marting · 发表于 2017-7-25 17:21:17

q3_2006 发表于 2017-7-25 17:17

编辑好了。

yaokui25 · 发表于 2017-7-25 18:03:06

非常感谢楼主

434939575 · 发表于 2017-7-25 19:36:15

辛苦了！这么长！谢谢！

yoyoho · 发表于 2017-7-25 20:31:30

感谢分享程序！！！

zixuan203344 · 发表于 2017-7-25 21:28:58

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

kqqt6236 · 发表于 2017-7-26 00:05:38

这个牛。

laiz3000 · 发表于 2017-7-26 00:22:04

看看效果

HLCAD · 发表于 2017-7-26 07:35:24

大师的作品，一定得好好学习学习

ynpxqjlb · 发表于 2018-1-13 11:53:04

学习一下！！！！！！！！！

igood · 发表于 2018-1-13 22:06:13

值得好好学习一下

cable2004 · 发表于 2018-1-13 22:15:16

非常感谢楼主

auva · 发表于 2018-6-16 07:23:54

正好需要，感谢感谢！

账号		自动登录	找回密码
密码			立即注册

[每日一码] 连接LINE到3DPOLYLINE

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。