面域转多段线VLISP代码

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

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

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

×

(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)
)

(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函数：

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

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代码

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

评分