找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 1088|回复: 17

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

[复制链接]

已领礼包: 20个

财富等级: 恭喜发财

发表于 2017-7-25 17:10:13 | 显示全部楼层 |阅读模式

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

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

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

  1. (defun c:joinlines23dpolys (/            *error* _vl-position    uniquechain
  2.                             adoc    ss            ti            elst    e
  3.                             e1            ee            eg            egg            entl
  4.                             pl            p            pp            f            chainl
  5.                             vertl   vts            tmp
  6.                            )
  7.   (vl-load-com)
  8.   (defun *error* (m)
  9.     (vla-endundomark adoc)
  10.     (if        m
  11.       (prompt m)
  12.     )
  13.     (princ)
  14.   )
  15.   ;; (_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) ;;
  16.   (defun _vl-position (e l tol k)
  17.     (if        (null k)
  18.       (setq k 0)
  19.     )
  20.     (if        (not (equal e (car l) tol))
  21.       (progn (setq k (1+ k))
  22.              (if (cdr l)
  23.                (_vl-position e (cdr l) tol k)
  24.                (setq k nil)
  25.              )
  26.       )
  27.       k
  28.     )
  29.   )

  30.   (vla-startundomark
  31.     (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  32.   )
  33.   (setq ss (ssget "_:L" '((0 . "LINE"))))
  34.   (setq ti (car (_vl-times)))
  35.   (setq elst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  36.   (setq        entl (mapcar '(lambda (x)
  37.                         (list (vlax-curve-getstartpoint x)
  38.                               (vlax-curve-getendpoint x)
  39.                               x
  40.                         )
  41.                       )
  42.                      elst
  43.              )
  44.   )
  45.   (setq entl (uniquechain entl))
  46.   (foreach e elst (entdel e))
  47.   (setq elst (mapcar 'caddr entl))
  48.   (foreach e elst (entdel e))
  49.   (while (or ee
  50.              (setq e  (car elst)
  51.                    e1 e
  52.              )
  53.          )
  54.     (if        (vl-some '(lambda (x)
  55.                     (or        (equal (vlax-curve-getstartpoint e)
  56.                                (vlax-curve-getstartpoint x)
  57.                                1e-6
  58.                         )
  59.                         (equal (vlax-curve-getstartpoint e)
  60.                                (vlax-curve-getendpoint x)
  61.                                1e-6
  62.                         )
  63.                         (equal (vlax-curve-getendpoint e)
  64.                                (vlax-curve-getstartpoint x)
  65.                                1e-6
  66.                         )
  67.                         (equal (vlax-curve-getendpoint e)
  68.                                (vlax-curve-getendpoint x)
  69.                                1e-6
  70.                         )
  71.                     )
  72.                   )
  73.                  (setq tmp (vl-remove e elst))
  74.         )
  75.       (cond ((vl-some '(lambda (x)
  76.                          (if (equal (vlax-curve-getstartpoint e)
  77.                                     (vlax-curve-getstartpoint x)
  78.                                     1e-6
  79.                              )
  80.                            (setq ee x)
  81.                            (setq ee nil)
  82.                          )
  83.                        )
  84.                       tmp
  85.              )
  86.              (if (not (vl-position e eg))
  87.                (setq eg (cons e eg))
  88.              )
  89.             )
  90.             ((vl-some '(lambda (x)
  91.                          (if (equal (vlax-curve-getstartpoint e)
  92.                                     (vlax-curve-getendpoint x)
  93.                                     1e-6
  94.                              )
  95.                            (setq ee x)
  96.                            (setq ee nil)
  97.                          )
  98.                        )
  99.                       tmp
  100.              )
  101.              (if (not (vl-position e eg))
  102.                (setq eg (cons e eg))
  103.              )
  104.             )
  105.             ((vl-some '(lambda (x)
  106.                          (if (equal (vlax-curve-getendpoint e)
  107.                                     (vlax-curve-getstartpoint x)
  108.                                     1e-6
  109.                              )
  110.                            (setq ee x)
  111.                            (setq ee nil)
  112.                          )
  113.                        )
  114.                       tmp
  115.              )
  116.              (if (not (vl-position e eg))
  117.                (setq eg (cons e eg))
  118.              )
  119.             )
  120.             ((vl-some '(lambda (x)
  121.                          (if (equal (vlax-curve-getendpoint e)
  122.                                     (vlax-curve-getendpoint x)
  123.                                     1e-6
  124.                              )
  125.                            (setq ee x)
  126.                            (setq ee nil)
  127.                          )
  128.                        )
  129.                       tmp
  130.              )
  131.              (if (not (vl-position e eg))
  132.                (setq eg (cons e eg))
  133.              )
  134.             )
  135.       )
  136.       (if (null eg)
  137.         (setq eg  (cons e eg)
  138.               egg (cons eg egg)
  139.               ee  nil
  140.               eg  nil
  141.               f          nil
  142.         )
  143.         (if (null f)
  144.           (progn (if (not (vl-position e eg))
  145.                    (setq eg (cons e eg))
  146.                  )
  147.                  (setq ee e1
  148.                        f  t
  149.                  )
  150.           )
  151.           (progn (if (not (vl-position e eg))
  152.                    (setq eg (cons e eg))
  153.                  )
  154.                  (setq ee  nil
  155.                        egg (cons eg egg)
  156.                        eg  nil
  157.                        f   nil
  158.                  )
  159.           )
  160.         )
  161.       )
  162.     )
  163.     (setq elst (vl-remove e elst))
  164.     (if        ee
  165.       (setq e ee)
  166.     )
  167.   )
  168.   (foreach eg egg
  169.     (if        (/= (length eg) 1)
  170.       (while (> (length eg) 1)
  171.         (setq pp nil
  172.               f         nil
  173.         )
  174.         (setq entl (mapcar '(lambda (x)
  175.                               (list (vlax-curve-getstartpoint x)
  176.                                     (vlax-curve-getendpoint x)
  177.                                     x
  178.                               )
  179.                             )
  180.                            eg
  181.                    )
  182.         )
  183.         (setq pl (vl-remove-if
  184.                    '(lambda (x) (= (type x) 'ENAME))
  185.                    (apply 'append entl)
  186.                  )
  187.         )
  188.         (while (setq p (car pl))
  189.           (if (_vl-position p (cdr pl) 1e-6 nil)
  190.             (setq pl (vl-remove-if '(lambda (x) (equal p x 1e-6)) pl))
  191.             (setq pp p
  192.                   pl (cdr pl)
  193.             )
  194.           )
  195.         )
  196.         (if pp
  197.           (setq        e (vl-some '(lambda (x)
  198.                               (if (or (equal (car x) pp 1e-6)
  199.                                       (equal (cadr x) pp 1e-6)
  200.                                   )
  201.                                 x
  202.                               )
  203.                             )
  204.                            entl
  205.                   )
  206.           )
  207.           (setq e (car entl))
  208.         )
  209.         (while e
  210.           (setq chainl (cons e chainl))
  211.           (setq        e
  212.                  (vl-some
  213.                    '(lambda (x)
  214.                       (cond
  215.                         ((and pp (= (length chainl) 1))
  216.                          (if (equal (car e) pp 1e-6)
  217.                            (cond
  218.                              ((equal (cadr e) (car x) 1e-6) (setq f t) x)
  219.                              ((equal (cadr e) (cadr x) 1e-6)
  220.                               (setq f nil)
  221.                               x
  222.                              )
  223.                            )
  224.                            (cond
  225.                              ((equal (car e) (car x) 1e-6) (setq f t) x)
  226.                              ((equal (car e) (cadr x) 1e-6)
  227.                               (setq f nil)
  228.                               x
  229.                              )
  230.                            )
  231.                          )
  232.                         )
  233.                         ((= (length chainl) 1)
  234.                          (cond
  235.                            ((equal (cadr e) (car x) 1e-6) (setq f t) x)
  236.                            ((equal (cadr e) (cadr x) 1e-6) (setq f nil) x)
  237.                          )
  238.                         )
  239.                         (t
  240.                          (cond
  241.                            ((and f (equal (cadr e) (car x) 1e-6))
  242.                             (setq f t)
  243.                             x
  244.                            )
  245.                            ((and f (equal (cadr e) (cadr x) 1e-6))
  246.                             (setq f nil)
  247.                             x
  248.                            )
  249.                            ((and (null f) (equal (car e) (car x) 1e-6))
  250.                             (setq f t)
  251.                             x
  252.                            )
  253.                            ((and (null f) (equal (car e) (cadr x) 1e-6))
  254.                             (setq f nil)
  255.                             x
  256.                            )
  257.                          )
  258.                         )
  259.                       )
  260.                     )
  261.                    (setq entl (vl-remove e entl))
  262.                  )
  263.           )
  264.         )
  265.         (setq chainl (reverse chainl))
  266.         (if pp
  267.           (setq
  268.             vertl (append (list        (if (equal (caar chainl) pp 1e-6)
  269.                                   (caar chainl)
  270.                                   (cadar chainl)
  271.                                 )
  272.                           )
  273.                           (setq        vts
  274.                                  (mapcar
  275.                                    '(lambda (a b)
  276.                                       (cond
  277.                                         ((equal (car a) (car b) 1e-6) (car a))
  278.                                         ((equal (car a) (cadr b) 1e-6)
  279.                                          (car a)
  280.                                         )
  281.                                         ((equal (cadr a) (car b) 1e-6)
  282.                                          (cadr a)
  283.                                         )
  284.                                         ((equal (cadr a) (cadr b) 1e-6)
  285.                                          (cadr a)
  286.                                         )
  287.                                       )
  288.                                     )
  289.                                    chainl
  290.                                    (cdr chainl)
  291.                                  )
  292.                           )
  293.                           (vl-remove-if
  294.                             '(lambda (x) (equal x (last vts) 1e-6))
  295.                             (vl-remove-if
  296.                               '(lambda (x) (= (type x) 'ENAME))
  297.                               (last chainl)
  298.                             )
  299.                           )
  300.                   )
  301.           )
  302.           (setq        vertl
  303.                  (append
  304.                    (list (caar chainl))
  305.                    (mapcar
  306.                      '(lambda (a b)
  307.                         (cond ((equal (car a) (car b) 1e-6) (car a))
  308.                               ((equal (car a) (cadr b) 1e-6) (car a))
  309.                               ((equal (cadr a) (car b) 1e-6) (cadr a))
  310.                               ((equal (cadr a) (cadr b) 1e-6) (cadr a))
  311.                         )
  312.                       )
  313.                      chainl
  314.                      (cdr chainl)
  315.                    )
  316.                  )
  317.           )
  318.         )
  319.         (foreach chain chainl
  320.           (setq eg (vl-remove (caddr chain) eg))
  321.           (entdel (caddr chain))
  322.         )
  323.         (setq chainl nil)
  324.         (if (car vertl)
  325.           (progn (entmake (list        '(0 . "POLYLINE")
  326.                                 '(100 . "AcDbEntity")
  327.                                 '(100 . "AcDb3dPolyline")
  328.                                 '(66 . 1)
  329.                                 '(10 0.0 0.0 0.0)
  330.                                 (if pp
  331.                                   (cons 70 8)
  332.                                   (cons 70 9)
  333.                                 )
  334.                                 '(210 0.0 0.0 1.0)
  335.                           )
  336.                  )
  337.                  (foreach pt vertl
  338.                    (entmake (list '(0 . "VERTEX")
  339.                                   '(100 . "AcDbEntity")
  340.                                   '(100 . "AcDbVertex")
  341.                                   '(100 . "AcDb3dPolylineVertex")
  342.                                   (cons 10 pt)
  343.                                   '(70 . 32)
  344.                             )
  345.                    )
  346.                  )
  347.                  (entmake (list '(0 . "SEQEND") '(100 . "AcDbEntity")))
  348.           )
  349.         )
  350.         (setq vertl nil)
  351.       )
  352.     )
  353.   )
  354.   (prompt "\nElapsed time : ")
  355.   (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 20))
  356.   (prompt " seconds...")
  357.   (*error* nil)
  358.   (princ)
  359. )


函数uniquechain


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

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 2476个

财富等级: 金玉满堂

发表于 2017-7-25 17:15:48 | 显示全部楼层
三维用得少..先收下存档..
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2476个

财富等级: 金玉满堂

发表于 2017-7-25 17:17:20 | 显示全部楼层
函数uniquechain 是乱码..拜托大师重贴一下..谢谢!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 20个

财富等级: 恭喜发财

 楼主| 发表于 2017-7-25 17:21:17 | 显示全部楼层
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 303个

财富等级: 日进斗金

发表于 2017-7-25 18:03:06 | 显示全部楼层
非常感谢楼主
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 1336个

财富等级: 财源广进

发表于 2017-7-25 19:36:15 | 显示全部楼层
辛苦了!这么长!谢谢!

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 8710个

财富等级: 富甲天下

发表于 2017-7-25 20:31:30 | 显示全部楼层
感谢分享程序!!!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 26个

财富等级: 恭喜发财

发表于 2017-7-25 21:28:58 | 显示全部楼层
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复

使用道具 举报

已领礼包: 6056个

财富等级: 富甲天下

发表于 2017-7-26 00:05:38 | 显示全部楼层
这个牛。         
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 475个

财富等级: 日进斗金

发表于 2017-7-26 00:22:04 | 显示全部楼层
看看效果
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复

使用道具 举报

已领礼包: 5578个

财富等级: 富甲天下

发表于 2017-7-26 07:35:24 | 显示全部楼层
大师的作品,一定得好好学习学习
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 22个

财富等级: 恭喜发财

发表于 2018-1-13 11:53:04 | 显示全部楼层
学习一下!!!!!!!!!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复

使用道具 举报

已领礼包: 97个

财富等级: 招财进宝

发表于 2018-1-13 22:06:13 | 显示全部楼层
值得好好学习一下
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2226个

财富等级: 金玉满堂

发表于 2018-1-13 22:15:16 | 显示全部楼层
非常感谢楼主
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 3031个

财富等级: 富可敌国

发表于 2018-6-16 07:23:54 | 显示全部楼层
正好需要,感谢感谢!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-3-29 03:51 , Processed in 0.307821 second(s), 56 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表