设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 3150|回复: 96

[每日一码] (BBPOLY)LINE,LWPOLYLINE生成拓扑边界区域

  [复制链接]

已领礼包: 19个

财富等级: 恭喜发财

发表于 2018-3-19 22:55:03 | 显示全部楼层 |阅读模式

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

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

x
以前收集的,看到今天有朋友问这个,找出来分享给大家。
这个是拓扑由LINE和LWPOLYLINE组成的曲线的所有联通边界,只适合只有直线段的LWPOLYLINE

LW-BPOLY.gif

  1. ;; Batch BPoly  -  Lee Mac
  2. ;; Generates polylines for every region formed by a selection of lines & polylines
  3. ;; Restricted to LWPolylines with linear segments only.
  4. ;; Region generation based on a method by Stefan M.

  5. (defun c:bbpoly ( / *error* big ent enx idx int lst pt1 pt2 rtn sel spc tmp tot val var vtx )

  6.     (defun *error* ( msg )
  7.         (foreach obj rtn
  8.             (if (and (vlax-write-enabled-p obj) (not (vlax-erased-p obj)))
  9.                 (vla-delete obj)
  10.             )
  11.         )
  12.         (mapcar 'setvar var val)
  13.         (LM:endundo (LM:acdoc))
  14.         (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
  15.             (princ (strcat "\nError: " msg))
  16.         )
  17.         (princ)
  18.     )

  19.     (LM:startundo (LM:acdoc))
  20.     (cond
  21.         (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
  22.             (princ "\nCurrent layer locked.")
  23.         )
  24.         (   (setq sel
  25.                 (LM:ssget "\nSelect Lines & Polylines: "
  26.                     (list
  27.                         (list
  28.                            '(-4 . "<OR")
  29.                                '(0 . "LINE")
  30.                                '(-4 . "<AND")
  31.                                    '(0 . "LWPOLYLINE")
  32.                                    '(-4 . "<NOT")
  33.                                        '(-4 . "<>")
  34.                                        '(42 . 0.0)
  35.                                    '(-4 . "NOT>")
  36.                                '(-4 . "AND>")
  37.                            '(-4 . "OR>")
  38.                             (if (= 1 (getvar 'cvport))
  39.                                 (cons 410 (getvar 'ctab))
  40.                                '(410 . "Model")
  41.                             )
  42.                         )
  43.                     )
  44.                 )
  45.             )
  46.             (setq spc
  47.                 (vlax-get-property (LM:acdoc)
  48.                     (if (= 1 (getvar 'cvport))
  49.                         'paperspace
  50.                         'modelspace
  51.                     )
  52.                 )
  53.             )
  54.             (repeat (setq idx (sslength sel))
  55.                 (if (= "LINE" (cdr (assoc 0 (setq enx (entget (ssname sel (setq idx (1- idx))))))))
  56.                     (setq lst (cons (list (cdr (assoc 10 enx)) (cdr (assoc 11 enx))) lst))
  57.                     (setq vtx (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx))
  58.                           vtx (mapcar 'list vtx (if (= 1 (logand 1 (cdr (assoc 70 enx)))) (cons (last vtx) vtx) (cdr vtx)))
  59.                           lst (append vtx lst)
  60.                     )
  61.                 )
  62.             )
  63.             (foreach pl1 lst
  64.                 (setq pt1 (car  pl1)
  65.                       pt2 (cadr pl1)
  66.                 )
  67.                 (foreach pl2 lst
  68.                     (if
  69.                         (and
  70.                             (not (equal pl1 pl2 1e-8))
  71.                             (setq int (inters pt1 pt2 (car pl2) (cadr pl2)))
  72.                             (not (vl-member-if '(lambda ( pnt ) (equal pnt int 1e-8)) pl1))
  73.                         )
  74.                         (setq pl1 (cons int pl1))
  75.                     )
  76.                 )
  77.                 (setq rtn
  78.                     (append
  79.                         (mapcar
  80.                             (function
  81.                                 (lambda ( a b )
  82.                                     (vla-addline spc
  83.                                         (vlax-3D-point a)
  84.                                         (vlax-3D-point b)
  85.                                     )
  86.                                 )
  87.                             )
  88.                             (setq pl1
  89.                                 (vl-sort pl1
  90.                                     (function
  91.                                         (lambda ( a b )
  92.                                             (< (distance pt1 a) (distance pt1 b))
  93.                                         )
  94.                                     )
  95.                                 )
  96.                             )
  97.                             (cdr pl1)
  98.                         )
  99.                         rtn
  100.                     )
  101.                 )
  102.             )
  103.             (setq var '(cmdecho peditaccept)
  104.                   val  (mapcar 'getvar var)
  105.                   tot  0.0
  106.             )
  107.             (mapcar 'setvar var '(0 1))
  108.             (foreach reg (vlax-invoke spc 'addregion rtn)
  109.                 (setq ent (entlast))
  110.                 (command "_.pedit" "_m")
  111.                 (apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke reg 'explode)))
  112.                 (command "" "_j" "" "")
  113.                 (if
  114.                     (and
  115.                         (not (eq ent (setq ent (entlast))))
  116.                         (= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
  117.                     )
  118.                     (progn
  119.                         (setq tmp (vlax-curve-getarea ent)
  120.                               tot (+ tot tmp)
  121.                         )
  122.                         (if (< (car big) tmp)
  123.                             (setq big (list tmp ent))
  124.                         )
  125.                     )
  126.                 )
  127.                 (vla-delete reg)
  128.             )
  129.             (if (equal (car big) (/ tot 2.0) 1e-3) ;; Gian Paolo Cattaneo
  130.                 (entdel (cadr big))
  131.             )
  132.             (foreach obj rtn (vla-delete obj))
  133.             (mapcar 'setvar var val)
  134.         )
  135.     )
  136.     (LM:endundo (LM:acdoc))
  137.     (princ)
  138. )

  139. ;; Start Undo  -  Lee Mac
  140. ;; Opens an Undo Group.

  141. (defun LM:startundo ( doc )
  142.     (LM:endundo doc)
  143.     (vla-startundomark doc)
  144. )

  145. ;; End Undo  -  Lee Mac
  146. ;; Closes an Undo Group.

  147. (defun LM:endundo ( doc )
  148.     (while (= 8 (logand 8 (getvar 'undoctl)))
  149.         (vla-endundomark doc)
  150.     )
  151. )

  152. ;; Active Document  -  Lee Mac
  153. ;; Returns the VLA Active Document Object

  154. (defun LM:acdoc nil
  155.     (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
  156.     (LM:acdoc)
  157. )
  158. (vl-load-com) (princ)



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

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

已领礼包: 6466个

财富等级: 富甲天下

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

使用道具 举报

已领礼包: 7525个

财富等级: 富甲天下

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

使用道具 举报

已领礼包: 2476个

财富等级: 金玉满堂

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

使用道具 举报

已领礼包: 5559个

财富等级: 富甲天下

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

使用道具 举报

已领礼包: 2809个

财富等级: 家财万贯

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

使用道具 举报

已领礼包: 811个

财富等级: 财运亨通

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

使用道具 举报

已领礼包: 4384个

财富等级: 富可敌国

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

使用道具 举报

已领礼包: 722个

财富等级: 财运亨通

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

使用道具 举报

已领礼包: 333个

财富等级: 日进斗金

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

使用道具 举报

已领礼包: 2711个

财富等级: 家财万贯

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

使用道具 举报

点击这里给我发消息

已领礼包: 2083个

财富等级: 金玉满堂

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

使用道具 举报

已领礼包: 20个

财富等级: 恭喜发财

发表于 2018-3-20 09:43:28 | 显示全部楼层
这类问题的本质都是把曲线在所有交点的地方打断,然后生成region, 再region->POLYLINE
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2557个

财富等级: 家财万贯

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

使用道具 举报

已领礼包: 31个

财富等级: 招财进宝

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

使用道具 举报

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

本版积分规则

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

GMT+8, 2020-10-31 15:48 , Processed in 0.215149 second(s), 92 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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