[编程交流] 在两条闭合多段线之间创建边界

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


    (defun *error* ( msg )
        (foreach obj rtn
            (if (and (vlax-write-enabled-p obj) (not (vlax-erased-p obj)))
                (vla-delete obj)
            )
        )
        (mapcar 'setvar var val)
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

    (LM:startundo (LM:acdoc))
    (cond
        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
            (princ "\nCurrent layer locked.")
        )
        (   (setq sel
                (LM:ssget "\nSelect Lines or Polylines: "
                    (list
                        (list
                           '(-4 . "<OR")
                               '(0 . "LINE")
                               '(-4 . "<AND")
                                   '(0 . "LWPOLYLINE")
                                   '(-4 . "<NOT")
                                       '(-4 . "<>")
                                       '(42 . 0.0)
                                   '(-4 . "NOT>")
                               '(-4 . "AND>")
                           '(-4 . "OR>")
                            (if (= 1 (getvar 'cvport))
                                (cons 410 (getvar 'ctab))
                               '(410 . "Model")
                            )
                        )
                    )
                )
            )
            (setq spc
                (vlax-get-property (LM:acdoc)
                    (if (= 1 (getvar 'cvport))
                        'paperspace
                        'modelspace
                    )
                )
            )
            (repeat (setq idx (sslength sel))
                (if (= "LINE" (cdr (assoc 0 (setq enx (entget (ssname sel (setq idx (1- idx))))))))
                    (setq lst (cons (list (cdr (assoc 10 enx)) (cdr (assoc 11 enx))) lst))
                    (setq vtx (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) enx))
                          vtx (mapcar 'list vtx (if (= 1 (logand 1 (cdr (assoc 70 enx)))) (cons (last vtx) vtx) (cdr vtx)))
                          lst (append vtx lst)
                    )
                )
            )
            (foreach pl1 lst
                (setq pt1 (car  pl1)
                      pt2 (cadr pl1)
                )
                (foreach pl2 lst
                    (if
                        (and
                            (not (equal pl1 pl2 1e-8))
                            (setq int (inters pt1 pt2 (car pl2) (cadr pl2)))
                            (not (vl-member-if '(lambda ( pnt ) (equal pnt int 1e-8)) pl1))
                        )
                        (setq pl1 (cons int pl1))
                    )
                )
                (setq rtn
                    (append
                        (mapcar
                            (function
                                (lambda ( a b )
                                    (vla-addline spc
                                        (vlax-3D-point a)
                                        (vlax-3D-point b)
                                    )
                                )
                            )
                            (setq pl1
                                (vl-sort pl1
                                    (function
                                        (lambda ( a b )
                                            (< (distance pt1 a) (distance pt1 b))
                                        )
                                    )
                                )
                            )
                            (cdr pl1)
                        )
                        rtn
                    )
                )
            )
            (setq var '(cmdecho peditaccept)
                  val  (mapcar 'getvar var)
                  tot  0.0
            )
            (mapcar 'setvar var '(0 1))
            (foreach reg (vlax-invoke spc 'addregion rtn)
                (setq ent (entlast))
                (command "_.pedit" "_m")
                (apply 'command (mapcar 'vlax-vla-object->ename (vlax-invoke reg 'explode)))
                (command "" "_j" "" "")
                (if
                    (and
                        (not (eq ent (setq ent (entlast))))
                        (= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
                    )
                    (progn
                        (setq tmp (vlax-curve-getarea ent)
                              tot (+ tot tmp)
                        )
                        (if (< (car big) tmp)
                            (setq big (list tmp ent))
                        )
                    )
                )
                (vla-delete reg)
            )
            (if (equal (car big) (/ tot 2.0) 1e-3) ;; Gian Paolo Cattaneo
                (entdel (cadr big))
            )
            (foreach obj rtn (vla-delete obj))
            (mapcar 'setvar var val)
        )
    )
    (LM:endundo (LM:acdoc))


    (princ)
)

;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)

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

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

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

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)
(vl-load-com) (princ)