【面域】面域转多段线 region to PLINE

月下闲人

(defun c:TT (/ *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)
)

boboxiake

6666666666666

nijiea123

不错，来学习一下