论坛 › A/VLISP › 面域转多段线VLISP代码

marting 发表于 2017-5-12 18:41:22

面域转多段线VLISP代码

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

;;;***************************************************************;;;

(defun *error* (msg)
    (if      (/= msg "Function cancelled")
      (princ (strcat "\nError: " msg))
    )
    (vla-EndUndoMark
      (vla-get-ActiveDocument (vlax-get-acad-object))
    )
    (princ)
)
;;;***************************************************************;;;

(setq      acdoc      (vla-get-ActiveDocument (vlax-get-acad-object))
      space      (if (= 1 (getvar "CVPORT"))
                  (vla-get-PaperSpace acdoc)
                  (vla-get-ModelSpace acdoc)
                )
)
(if (ssget '((0 . "REGION")))
    (progn
      (vla-StartUndoMark acdoc)
      (vlax-for reg (setq ss (vla-get-ActiveSelectionSet acdoc))
      (setq norm (vlax-get reg 'Normal)
            expl (vlax-invoke reg 'Explode)
      )
      (if (vl-every '(lambda (x)
                         (or
                           (= (vla-get-ObjectName x) "AcDbLine")
                           (= (vla-get-ObjectName x) "AcDbArc")
                         )
                     )
                      expl
            )
          (progn
            (vla-delete reg)
            (setq olst (mapcar '(lambda      (x)
                                  (list      x
                                        (vlax-get x 'StartPoint)
                                        (vlax-get x 'EndPoint)
                                  )
                              )
                               expl
                     )
            )
            (while olst
            (setq blst nil)
            (if (= (vla-get-ObjectName (caar olst)) "AcDbArc")
                (setq blst (list (cons 0 (arcbulge (caar olst)))))
            )
            (setq plst (cdar olst)
                  dlst (list (caar olst))
                  olst (cdr olst)
            )
            (while
                (setq
                  tlst
                   (vl-member-if
                     '(lambda (x)
                        (or (equal (last plst) (cadr x) 1e-9)
                            (equal (last plst) (caddr x) 1e-9)
                        )
                      )
                     olst
                   )
                )
               (if (equal (last plst) (caddar tlst) 1e-9)
                   (setq blg -1)
                   (setq blg 1)
               )
               (if
                   (= (vla-get-ObjectName (caar tlst)) "AcDbArc")
                  (setq
                      blst
                     (cons (cons (1- (length plst))
                                 (* blg (arcbulge (caar tlst)))
                           )
                           blst
                     )
                  )
               )
               (setq plst (append plst
                                    (if      (minusp blg)
                                    (list (cadar tlst))
                                    (list (caddar tlst))
                                    )
                            )
                     dlst (cons (caar tlst) dlst)
                     olst (vl-remove (car tlst) olst)
               )
            )
            (setq pline
                     (vlax-invoke
                     Space
                     'addLightWeightPolyline
                     (apply 'append
                              (mapcar '(lambda (x)
                                       (setq x (trans x 0 Norm))
                                       (list (car x) (cadr x))
                                       )
                                    (reverse (cdr (reverse plst)))
                              )
                     )
                     )
            )
            (vla-put-Closed pline :vlax-true)
            (mapcar
                '(lambda (x) (vla-setBulge pline (car x) (cdr x)))
                blst
            )
            (vla-put-Elevation
                pline
                (caddr (trans (car plst) 0 Norm))
            )
            (vla-put-Normal pline (vlax-3d-point Norm))
            (mapcar 'vla-delete dlst)
            )
          )
          (mapcar 'vla-delete expl)
      )
      )
      (vla-delete ss)
      (vla-EndUndoMark acdoc)
    )
)
(princ)
)



ARCBULGE函数：

**** Hidden Message *****

q3_2006 发表于 2017-5-12 18:48:55

这个厉害...必须收藏

cable2004 发表于 2017-5-12 20:44:30

这个厉害...必须收藏

ynhh 发表于 2017-5-12 21:20:00

有没有块外轮廓的啊谢谢你

sicky111 发表于 2017-5-13 00:43:29

收藏了         

HLCAD 发表于 2017-5-13 07:59:54

这个很实用，感谢楼主分享！

向嘟嘟 发表于 2017-5-13 08:14:36

看看。。。。。。。。。。。。。

lw5297590 发表于 2017-5-13 08:45:33

感谢楼主分享！

yjch 发表于 2017-5-13 08:57:18

好好学习天天向上，多段线提取，感谢

lhtfhc 发表于 2017-5-13 09:02:26

正需要谢谢分享

434939575 发表于 2017-5-13 09:28:00

大师高产了！谢谢分享！

Linhay 发表于 2017-5-13 09:41:22

回复看函数 谢谢楼主分享

sh_h 发表于 2017-5-13 10:04:36

感谢楼主分享！！！

longer1000 发表于 2017-5-13 10:41:11

感谢楼主分享！！！

winerfjy 发表于 2017-5-13 11:39:09

曲线转成的区域不能生成边界只能面域
反过来这个面域后再生成多线再生成边l界这个就可以有了

查看完整版本: 面域转多段线VLISP代码