AutoClose凸角多边形自动闭合(第2种办法)

admin1

[code]
;;;========================================================================================;;;
(defun c:tt (/ 2elst a b c d1 delpts en        endpts i lpts lss obj1 odlst pt1 pt2 ptiall ptilst ptm pts rpts        ss tf)
  (progn
    (vl-load-com)
    (defun yj-ss2lst (ss / i l)
      (if ss
        (repeat        (setq i (sslength ss))
          (setq l (cons (ssname ss (setq i (1- i))) l))
        )
      )
    )
;;;=====================================================   
    (defun IntersPointList (en1 lss / OBJ1 PTS)
      (setq lss (vl-remove en1 lss))
      (setq obj1 (vlax-ename->vla-object en1))
      (setq pts
             (vl-remove        nil
                        (mapcar        (function (lambda (x)
                                            (vlax-invoke
                                              obj1
                                              'IntersectWith
                                              (vlax-ename->vla-object x)
                                              acExtendboth
                                            )
                                          )
                                )
                                lss
                        )
             )
      )
    )
    ;|==============================================;;
;;;按序号删除表中的元素-------------------------yjtdkj.2021.07
参数: lst    － 表
参数: n      － 序号（从0开始）
参数: new    － 新元素
返回: 新表
例子: (yj-LST-Idxremove '(11 22 33) 0 )
|;
    (defun yj-LST-Idxremove (lst n / AA M NEWLST)
      (setq newLst '())
      (setq m 0)
      (repeat (length lst)
        (if (= m n)
          (progn
            (setq lst (cdr lst))
          )
          (progn
            (setq aa (car lst))
            (setq newLst (cons aa newLst))
            (setq lst (cdr lst))
          )
        )
        (setq m (1+ m))
      )
      (reverse newlst)
    )
;;;取表中两两相等的点的表
    (defun TwoEqual (ptlst / I NEWLST PT TMP)
      (setq tmp ptlst)
      (setq newlst '())
      (while tmp
        (setq pt  (car tmp)
              tmp (cdr tmp)
        ) ;end setq
        (repeat        (setq i (length tmp))
          (if (equal (nth (setq i (1- i)) tmp) pt 1e-6)
            (progn
              (setq newlst (cons pt newlst))
              (setq tmp (yj-LST-Idxremove tmp i))
            )
          )
        )
      )
      newlst
    )
;;;点表的差集
    (defun ptlst-subtract (lst1 lst2 / I NEWLST PT TMP)
      (while lst2
        (setq pt   (car lst2)
              lst2 (cdr lst2)
        ) ;end setq
        (repeat        (setq i (length lst1))
          (if (equal (nth (setq i (1- i)) lst1) pt 1e-6)
            (setq lst1 (yj-LST-Idxremove lst1 i))
          )
        )
      )
      lst1
    )
;;;点在点表中搜索，如果有，则返回找到的点及以后的表
    (defun memberpts (p lst / PT TF)
      (while (and lst (not tf))
        (setq pt (car lst))
        (if (equal p pt 1e-6)
          (setq tf t)
          (setq lst (cdr lst))
        )
      )
      lst
    )
;;;表变两元素表
    (defun lstto2Elst (lst / E I NEWLST)
      (setq newlst '())
      (while lst
        (setq e          (car lst)
              lst (cdr lst)
        )
        (if lst
          (repeat (setq i (length lst))
            (setq
              newlst (cons (list e (nth (setq i (1- i)) lst)) newlst)
            )
          )
        )
      )
      (reverse newlst)
    )
;;;
    (defun point2pline (lst ent / NEWENT)
      (setq newent '((0 . "LWPOLYLINE")))
      (foreach x '(100 67 410 62 6 370)
        (if (assoc x ent)
          (setq newent (cons (assoc x ent) newent))
        ) ;_  if
      )
      (vla-startundomark
        (vla-get-activedocument (vlax-get-acad-object))
      )
      (entmake
        (append
          (reverse newent)
          (list        '(100 . "AcDbPolyline")
                (cons 90 (length lst))
                '(70 . 1)
          )
          (apply 'append
                 (mapcar (function (lambda (x)
                                     (list
                                       (cons 10 (list (car x) (cadr x)))
                                       (cons 40 0.0)
                                       (cons 41 0.0)
                                       (cons 42 0.0)
                                     )
                                   )
                         )
                         lst
                 )
          )
          (list (assoc 210 ent))
        ) ;_  append
      )
      (vla-endundomark
        (vla-get-activedocument (vlax-get-acad-object))
      )
      (entlast)
    )
;;;----------------------------------------;;;
    (setq *acad        (vlax-get-acad-object)
          *doc        (vla-get-ActiveDocument *acad)
          ;;
          *ms        (if (= (getvar 'ctab) "Model")
                  (vla-get-modelSpace *doc)
                  (vla-get-paperSpace *doc)
                )
    )
    (defun *error* (msg)
      (mapcar 'setvar
              '("cmdecho" "osmode" "peditaccept" "Pickstyle")
              odlst
      )
      (vlax-invoke-method *doc 'EndUndoMark)
      (if (not
            (wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*")
          )
        (princ (strcat "\nError: " msg))
      )
      (princ)
    )
    (vlax-invoke-method *doc 'StartUndoMark)
    (setq
      odlst (mapcar 'getvar
                    '("cmdecho" "osmode" "peditaccept" "Pickstyle")
            )
    )
    (mapcar 'setvar
            '("cmdecho" "osmode" "peditaccept" "Pickstyle")
            '(0 0 1 0)
    )
  )
;;;---------------------------------------------------------------------
;;;-------------------主程序开始----------------------------------------
;;;---------------------------------------------------------------------
  (setq ss (ssget))
  (if ss
    (progn
      (setq lss (yj-ss2lst ss))
      (setq ptilst
             (mapcar (function (lambda (x) (IntersPointList x lss))) lss)
      )
      (setq PtiAll (apply 'append ptilst))
      (setq PtiAll (twoEqual PtiAll))
      (setq delpts '())
      (mapcar
        (function (lambda (x)
                    (setq lpts '())
                    (setq rpts '())
                    (setq pts (ptlst-subtract PtiAll x))
                    (while pts
                      (setq ptm        (car pts)
                            pts        (cdr pts)
                      )
                      (setq pt1        (car x)
                            pt2        (cadr x)
                      )
                      (setq
                        a  (- (cadr pt2) (cadr pt1))
                        b  (- (car pt1) (car pt2))
                        c  (- (* -1 a (car pt1)) (* b (cadr pt1)))
                        d1 (- (* -1 a (car ptm)) (* b (cadr ptm)))
                      )
                      (cond
                        ((= d1 c)
                         nil
                        )
                        ((> d1 c)
                         (setq lpts (cons ptm lpts))
                        )
                        ((< d1 c)
                         (setq rpts (cons ptm rpts))
                        )
                      )
                    )
                    (if        (< (length lpts) (length rpts))
                      (setq delpts (cons lpts delpts))
                      (setq delpts (cons rpts delpts))
                    )
                  )
        )
        ptilst
      )
      (setq delpts (apply 'append delpts))
      (setq PtiAll (ptlst-subtract PtiAll delpts))
      (setq 2elst (lstto2Elst PtiAll)) ;图元表转2元素图元表
      (setq 2elst (vl-remove-if-not
                    (function (lambda (x)
                                (setq tf nil)
                                (repeat        (setq i (length ptilst))
                                  (setq pts (nth (setq i (1- i)) ptilst))
                                  (if (and (memberpts (car x) pts)
                                           (memberpts (cadr x) pts)
                                      )
                                    (setq tf t)
                                  )
                                )
                                tf
                              )
                    )
                    2elst
                  )
      ) ;找到所有在线上两点
      (if (= (length 2elst) (length lss))
        (progn
          (setq endpts (car 2elst))
          (setq 2elst (cdr 2elst))
          (while (/= (length endpts) (length lss))
            (if        (or (= i 0) (not i))
              (setq i (length 2elst))
            )
            (setq pts (nth (setq i (1- i)) 2elst))
            (cond ((equal (car endpts) (cadr pts) 1e-6)
                   (progn
                     (setq endpts (cons (car pts) endpts))
                     (setq 2elst (yj-LST-Idxremove 2elst i))
                   )
                  )
                  ((equal (car endpts) (car pts) 1e-6)
                   (progn
                     (setq endpts (cons (cadr pts) endpts))
                     (setq 2elst (yj-LST-Idxremove 2elst i))
                   )
                  )
            )
          )
        )
      )
      (setq en (point2pline endpts (entget (car lss))))
    )
    (progn
      (mapcar 'setvar
              '("cmdecho" "osmode" "peditaccept" "Pickstyle")
              odlst
      )
      (exit)
    )
  )
  (mapcar 'setvar
          '("cmdecho" "osmode" "peditaccept" "Pickstyle")
          odlst
  )
  (vlax-invoke-method *doc 'EndUndoMark)

  (princ)
)[/code]