找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 614|回复: 7

[每日一码] LWPOLYLINE 布尔并(UNION)

[复制链接]

已领礼包: 40个

财富等级: 招财进宝

发表于 2021-1-17 03:47:56 | 显示全部楼层 |阅读模式

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

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

×
UPL2.gif

  1. ;;; ULP -Gilles Chanteau- 01/01/06
  2. ;;; Crée une polyligne sur le contour de chaque groupe de polylignes fermées et contiguës sélectionnées.
  3. ;;; Mise à jour: 19/04/2011 (fonctionnement 3d)

  4. (defun c:upl (/ *error* ss lst erase cnt)
  5.   (vl-load-com)

  6.   (or *acad* (setq *acad* (vlax-get-acad-object)))
  7.   (or *acdoc* (setq *acdoc* (vla-get-activeDocument *acad*)))

  8. ;;;***************************************************************;;;

  9.   (defun *error* (msg)
  10.     (and msg
  11.          (or
  12.            (= msg "Fonction annulée")
  13.            (= msg "quitter / sortir abandon")
  14.          )
  15.          (princ (strcat "\nErreur: " msg))
  16.     )
  17.     (vla-endundomark *acdoc*)
  18.     (princ)
  19.   )

  20.   (prompt "\nSélectionnez les polylignes à fusionner: ")
  21.   (if (ssget '((0 . "LWPOLYLINE") (-4 . "&") (70 . 1)))
  22.     (progn
  23.       (initget "Oui Non")
  24.       (setq erase (getkword "\nEffacer les polylignes source ? [Oui/Non] <Oui>: "))
  25.       (vlax-for        obj (setq ss (vla-get-ActiveSelectionSet *acdoc*))
  26.         (setq lst (cons obj lst))
  27.       )
  28.       (vla-Delete ss)
  29.       (vla-StartUndoMark *acdoc*)
  30.       (setq cnt (gc:MergePlines lst (/= erase "Non")))
  31.       (vla-EndUndoMark *acdoc*)
  32.       (princ (strcat "\n"
  33.                      (itoa cnt)
  34.                      (if (< 1 cnt)
  35.                        " polylignes créées."
  36.                        " polyligne créée."
  37.                      )
  38.              )
  39.       )
  40.     )
  41.   )
  42.   (*error* nil)
  43. )

  44. (defun gc:MergePlines (lst erase / arcbulge space tmp source reg elev norm expl        objs regs olst blst
  45.                        dlst plst tlst blg pline cnt)

  46.   (or *acad* (setq *acad* (vlax-get-acad-object)))
  47.   (or *acdoc* (setq *acdoc* (vla-get-activeDocument *acad*)))

  48.   (defun arcbulge (arc)
  49.     (/ (sin (/ (vla-get-TotalAngle arc) 4))
  50.        (cos (/ (vla-get-TotalAngle arc) 4))
  51.     )
  52.   )

  53.   (setq        space (if (= 1 (getvar "CVPORT"))
  54.                 (vla-get-PaperSpace *acdoc*)
  55.                 (vla-get-Modelspace *acdoc*)
  56.               )
  57.         cnt 0
  58.   )
  59.   (while lst
  60.     (setq tmp nil)
  61.     (setq source (car lst)
  62.           elev         (vla-get-Elevation source)
  63.           norm         (vlax-get source 'Normal)
  64.     )
  65.     (foreach p lst
  66.       (if (and (equal elev (vla-get-Elevation p) 1e-12)
  67.                (equal norm (vlax-get p 'Normal) 1e-2)
  68.           )
  69.         (setq tmp (cons p tmp)
  70.               lst (vl-remove p lst)
  71.         )
  72.       )
  73.     )
  74.     (if        (and
  75.           (< 1 (length tmp))
  76.           (setq reg (vlax-invoke space 'addRegion tmp))
  77.         )
  78.       (progn
  79.         (if erase
  80.           (mapcar 'vla-Delete tmp)
  81.         )
  82.         (while (cadr reg)
  83.           (vla-boolean (car reg) acUnion (cadr reg))
  84.           (setq reg (cons (car reg) (cddr reg)))
  85.         )
  86.         (setq reg  (car reg)
  87.               expl (vlax-invoke reg 'Explode)
  88.         )
  89.         (vla-delete reg)
  90.         (while expl
  91.           (setq        objs (vl-remove-if-not
  92.                        '(lambda        (x)
  93.                           (or
  94.                             (= (vla-get-ObjectName x) "AcDbLine")
  95.                             (= (vla-get-ObjectName x) "AcDbArc")
  96.                           )
  97.                         )
  98.                        expl
  99.                      )
  100.                 regs (vl-remove-if-not
  101.                        '(lambda (x) (= (vla-get-ObjectName x) "AcDbRegion"))
  102.                        expl
  103.                      )
  104.           )
  105.           (if objs
  106.             (progn
  107.               (setq olst (mapcar '(lambda (x)
  108.                                     (list x
  109.                                           (vlax-get x 'StartPoint)
  110.                                           (vlax-get x 'EndPoint)
  111.                                     )
  112.                                   )
  113.                                  objs
  114.                          )
  115.               )
  116.               (while olst
  117.                 (setq blst nil)
  118.                 (if (= (vla-get-ObjectName (caar olst)) "AcDbArc")
  119.                   (setq blst (list (cons 0 (arcbulge (caar olst)))))
  120.                 )
  121.                 (setq plst (cdar olst)
  122.                       dlst (list (caar olst))
  123.                       olst (cdr olst)
  124.                 )
  125.                 (while
  126.                   (setq
  127.                     tlst (vl-member-if
  128.                            '(lambda (x)
  129.                               (or (equal (last plst) (cadr x) 1e-9)
  130.                                   (equal (last plst) (caddr x) 1e-9)
  131.                               )
  132.                             )
  133.                            olst
  134.                          )
  135.                   )
  136.                    (if (equal (last plst) (caddar tlst) 1e-9)
  137.                      (setq blg -1)
  138.                      (setq blg 1)
  139.                    )
  140.                    (if (= (vla-get-ObjectName (caar tlst)) "AcDbArc")
  141.                      (setq
  142.                        blst (cons (cons        (1- (length plst))
  143.                                         (* blg (arcbulge (caar tlst)))
  144.                                   )
  145.                                   blst
  146.                             )
  147.                      )
  148.                    )
  149.                    (setq plst (append plst
  150.                                       (if (minusp blg)
  151.                                         (list (cadar tlst))
  152.                                         (list (caddar tlst))
  153.                                       )
  154.                               )
  155.                          dlst (cons (caar tlst) dlst)
  156.                          olst (vl-remove (car tlst) olst)
  157.                    )
  158.                 )
  159.                 (setq pline
  160.                        (vlax-invoke
  161.                          Space
  162.                          'addLightWeightPolyline
  163.                          (apply        'append
  164.                                 (mapcar        '(lambda (x)
  165.                                            (setq x (trans x 0 Norm))
  166.                                            (list (car x) (cadr x))
  167.                                          )
  168.                                         (reverse (cdr (reverse plst)))
  169.                                 )
  170.                          )
  171.                        )
  172.                 )
  173.                 (vla-put-Closed pline :vlax-true)
  174.                 (mapcar
  175.                   '(lambda (x) (vla-setBulge pline (car x) (cdr x)))
  176.                   blst
  177.                 )
  178.                 (vla-put-Elevation pline elev)
  179.                 (vla-put-Normal pline (vlax-3d-point norm))
  180.                 (mapcar 'vla-delete dlst)
  181.                 (setq cnt (1+ cnt))
  182.               )
  183.             )
  184.           )
  185.           (if regs
  186.             (progn
  187.               (setq
  188.                 expl (append (vlax-invoke (car regs) 'Explode)
  189.                              (cdr regs)
  190.                      )
  191.               )
  192.               (vla-delete (car regs))
  193.             )
  194.             (setq expl nil)
  195.           )
  196.         )
  197.       )
  198.     )
  199.   )
  200.   cnt
  201. )
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 5578个

财富等级: 富甲天下

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

使用道具 举报

已领礼包: 604个

财富等级: 财运亨通

发表于 2021-1-18 09:45:54 | 显示全部楼层
这个没有用面域,有点牛,留个记号,到此一游。同时感谢N版。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

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

使用道具 举报

已领礼包: 19个

财富等级: 恭喜发财

发表于 2021-1-19 13:27:12 | 显示全部楼层
/db_自贡黄明儒_ 发表于 2021-1-18 09:45
这个没有用面域,有点牛,留个记号,到此一游。同时感谢N版。

用了region的

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

使用道具 举报

已领礼包: 19个

财富等级: 恭喜发财

发表于 2021-1-19 13:32:42 | 显示全部楼层
zwwen12 发表于 2021-1-19 12:35
啥时候能来一个布尔交

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

使用道具 举报

已领礼包: 4365个

财富等级: 富可敌国

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

使用道具 举报

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

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 00:02 , Processed in 0.187257 second(s), 45 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

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