找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 17902|回复: 176

[每日一码] 面域转多段线VLISP代码

 火.. [复制链接]

已领礼包: 20个

财富等级: 恭喜发财

发表于 2017-5-12 18:41:22 | 显示全部楼层 |阅读模式

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

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

×
搜狗截图20170512183804.png

  1. (defun c:r2pl (/ *error*         arcbugle         acdoc         space
  2.                  ss         n         reg         norm         expl         olst
  3.                  blst         dlst         plst         tlst         blg         pline
  4.                 )
  5.   (vl-load-com)

  6. ;;;***************************************************************;;;

  7.   (defun *error* (msg)
  8.     (if        (/= msg "Function cancelled")
  9.       (princ (strcat "\nError: " msg))
  10.     )
  11.     (vla-EndUndoMark
  12.       (vla-get-ActiveDocument (vlax-get-acad-object))
  13.     )
  14.     (princ)
  15.   )
  16. ;;;***************************************************************;;;

  17.   (setq        acdoc        (vla-get-ActiveDocument (vlax-get-acad-object))
  18.         space        (if (= 1 (getvar "CVPORT"))
  19.                   (vla-get-PaperSpace acdoc)
  20.                   (vla-get-ModelSpace acdoc)
  21.                 )
  22.   )
  23.   (if (ssget '((0 . "REGION")))
  24.     (progn
  25.       (vla-StartUndoMark acdoc)
  26.       (vlax-for reg (setq ss (vla-get-ActiveSelectionSet acdoc))
  27.         (setq norm (vlax-get reg 'Normal)
  28.               expl (vlax-invoke reg 'Explode)
  29.         )
  30.         (if (vl-every '(lambda (x)
  31.                          (or
  32.                            (= (vla-get-ObjectName x) "AcDbLine")
  33.                            (= (vla-get-ObjectName x) "AcDbArc")
  34.                          )
  35.                        )
  36.                       expl
  37.             )
  38.           (progn
  39.             (vla-delete reg)
  40.             (setq olst (mapcar '(lambda        (x)
  41.                                   (list        x
  42.                                         (vlax-get x 'StartPoint)
  43.                                         (vlax-get x 'EndPoint)
  44.                                   )
  45.                                 )
  46.                                expl
  47.                        )
  48.             )
  49.             (while olst
  50.               (setq blst nil)
  51.               (if (= (vla-get-ObjectName (caar olst)) "AcDbArc")
  52.                 (setq blst (list (cons 0 (arcbulge (caar olst)))))
  53.               )
  54.               (setq plst (cdar olst)
  55.                     dlst (list (caar olst))
  56.                     olst (cdr olst)
  57.               )
  58.               (while
  59.                 (setq
  60.                   tlst
  61.                    (vl-member-if
  62.                      '(lambda (x)
  63.                         (or (equal (last plst) (cadr x) 1e-9)
  64.                             (equal (last plst) (caddr x) 1e-9)
  65.                         )
  66.                       )
  67.                      olst
  68.                    )
  69.                 )
  70.                  (if (equal (last plst) (caddar tlst) 1e-9)
  71.                    (setq blg -1)
  72.                    (setq blg 1)
  73.                  )
  74.                  (if
  75.                    (= (vla-get-ObjectName (caar tlst)) "AcDbArc")
  76.                     (setq
  77.                       blst
  78.                        (cons (cons (1- (length plst))
  79.                                    (* blg (arcbulge (caar tlst)))
  80.                              )
  81.                              blst
  82.                        )
  83.                     )
  84.                  )
  85.                  (setq plst (append plst
  86.                                     (if        (minusp blg)
  87.                                       (list (cadar tlst))
  88.                                       (list (caddar tlst))
  89.                                     )
  90.                             )
  91.                        dlst (cons (caar tlst) dlst)
  92.                        olst (vl-remove (car tlst) olst)
  93.                  )
  94.               )
  95.               (setq pline
  96.                      (vlax-invoke
  97.                        Space
  98.                        'addLightWeightPolyline
  99.                        (apply 'append
  100.                               (mapcar '(lambda (x)
  101.                                          (setq x (trans x 0 Norm))
  102.                                          (list (car x) (cadr x))
  103.                                        )
  104.                                       (reverse (cdr (reverse plst)))
  105.                               )
  106.                        )
  107.                      )
  108.               )
  109.               (vla-put-Closed pline :vlax-true)
  110.               (mapcar
  111.                 '(lambda (x) (vla-setBulge pline (car x) (cdr x)))
  112.                 blst
  113.               )
  114.               (vla-put-Elevation
  115.                 pline
  116.                 (caddr (trans (car plst) 0 Norm))
  117.               )
  118.               (vla-put-Normal pline (vlax-3d-point Norm))
  119.               (mapcar 'vla-delete dlst)
  120.             )
  121.           )
  122.           (mapcar 'vla-delete expl)
  123.         )
  124.       )
  125.       (vla-delete ss)
  126.       (vla-EndUndoMark acdoc)
  127.     )
  128.   )
  129.   (princ)
  130. )



ARCBULGE函数:

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

评分

参与人数 2D豆 +2 收起 理由
xx69as + 1 很给力!
boosder + 1 这个有BUG,有些求过差集的面域会出错!

查看全部评分

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

已领礼包: 2476个

财富等级: 金玉满堂

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

使用道具 举报

已领礼包: 2226个

财富等级: 金玉满堂

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

使用道具 举报

已领礼包: 6881个

财富等级: 富甲天下

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

使用道具 举报

已领礼包: 6468个

财富等级: 富甲天下

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

使用道具 举报

已领礼包: 5602个

财富等级: 富甲天下

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

使用道具 举报

已领礼包: 1443个

财富等级: 财源广进

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

使用道具 举报

已领礼包: 1827个

财富等级: 堆金积玉

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

使用道具 举报

已领礼包: 3191个

财富等级: 富可敌国

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

使用道具 举报

已领礼包: 1904个

财富等级: 堆金积玉

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

使用道具 举报

已领礼包: 1336个

财富等级: 财源广进

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

使用道具 举报

已领礼包: 28个

财富等级: 恭喜发财

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

使用道具 举报

已领礼包: 775个

财富等级: 财运亨通

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

使用道具 举报

已领礼包: 1304个

财富等级: 财源广进

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

使用道具 举报

已领礼包: 25个

财富等级: 恭喜发财

发表于 2017-5-13 11:39:09 | 显示全部楼层
曲线转成的区域不能生成边界只能面域
反过来这个面域后再生成多线再生成边l界这个就可以有了
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-12-4 23:41 , Processed in 0.484385 second(s), 60 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

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