lisp编程：请问，CAD中图形如何检查闭合

检查图形是否闭合，图形完全闭合，提示报警。箭头所指方向，图形没有闭合。检查版大小是1220*2440mm版，里面有十几块版拼起来组成
方式838178109

推荐答案 2017-08-11

;函数功能：找出封闭线
(defun c:tes ( / &jd1 &k1 &k2 &p1 &ss1 &ss2 &ss3 &ss5 x y)
(setvar "cmdecho" 0)
(setvar "blipmode" 0)
(if (null vlax-dump-object) (vl-load-com) )
(setq &jd1 1.0)
(if (setq &ss1 (a1611131));选择不封闭的对象
  (progn
   (setq &ss2 '())
   (while (and (setq &k1 (car &ss1)) (setq &ss1 (cdr &ss1)))
    (setq &p1 (vlax-curve-getStartPoint &k1) &ss5 (list &k1))
    (setq &ss3 (a1611132 &ss1 &p1 &jd1) &k2 (car &ss3) &ss1 (cadr &ss3))
    (while &k2
     (setq &ss5 (cons &k2 &ss5))
     (if &ss1
      (progn;;2
       (setq &p1 (cadar (vl-sort
                 (mapcar '(lambda (x) (list (distance &p1 x) x))
                 (list (vlax-curve-getStartPoint &k2) (vlax-curve-getEndPoint &k2)))
                '(lambda (x y) (> (car x) (car y))))
       ))
       (setq &ss3 (a1611132 &ss1 &p1 &jd1) &k2 (car &ss3) &ss1 (cadr &ss3))
      );progn;2
      (setq &k2 nil)
     );if;2
    );while;2
    (setq &p1 (vlax-curve-getEndPoint &k1) &ss5 (reverse &ss5))
    (setq &ss3 (a1611132 &ss1 &p1 &jd1) &k2 (car &ss3) &ss1 (cadr &ss3))
    (while &k2
     (setq &ss5 (cons &k2 &ss5))
     (if &ss1
      (progn;;3
       (setq &p1 (cadar (vl-sort
                 (mapcar '(lambda (x) (list (distance &p1 x) x))
                 (list (vlax-curve-getStartPoint &k2) (vlax-curve-getEndPoint &k2)))
                '(lambda (x y) (> (car x) (car y))))
       ))
       (setq &ss3 (a1611132 &ss1 &p1 &jd1) &k2 (car &ss3) &ss1 (cadr &ss3))
      );progn;3
      (setq &k2 nil)
     );if;3
    );while;3
    (if (cadr &ss5) (a1611133 &ss5 &jd1) )
   );while
  )
)
(princ)
)

;函数功能：计算坐标
(defun a1611135 (obj @p5 / @p5 obj)
(if (= (cadr @p5) 1)
   (list (vlax-curve-getStartPoint obj) (vlax-curve-getEndPoint obj))
   (list (vlax-curve-getEndPoint obj) (vlax-curve-getStartPoint obj))
)
)

;函数功能：判断起点与端点
(defun a1611134 (obj @p1 / @p1 obj x y)
(setq @p1 (caddr @p1))
(cdar (vl-sort
(mapcar '(lambda (x) (cons (distance @p1 (car x)) x))
(list (list (vlax-curve-getStartPoint obj) 1 (vlax-curve-getEndPoint obj)) (list (vlax-curve-getEndPoint obj) 2 (vlax-curve-getStartPoint obj))))
'(lambda (x y) (< (car x) (car y)))))
)

;函数功能：分析坐标
(defun a1611133 (&ss5 cd1 / &k1 &k2 &p1 &p2 &p3 &p4 &p5 &ss2 &ss5 cd1 x y)
(setq &k1 (car &ss5) &k2 (cadr &ss5)
       &p1 (vlax-curve-getStartPoint &k1) &p2 (vlax-curve-getEndPoint &k1)
       &p3 (vlax-curve-getStartPoint &k2) &p4 (vlax-curve-getEndPoint &k2)
       &p5 (cdar (vl-sort
           (mapcar '(lambda (x) (list (distance (car x) (cadr x)) (car x) (caddr x) (cadddr x)))
           (list (list &p1 &p3 2 &p3) (list &p1 &p4 2 &p4) (list &p2 &p3 1 &p3) (list &p2 &p4 1 &p4)))
          '(lambda (x y) (< (car x) (car y)))))
)
(setq &p1 (car (a1611135 &k1 &p5)) &ss2 (cdr &ss5))
(setq &p2 (cadr (last (mapcar '(lambda (x) (a1611135 x (setq &p5 (a1611134 x &p5)))) &ss2))))
(if (< (distance &p1 &p2) cd1) (mapcar '(lambda (x) (vla-put-color x 256)) &ss5) )
)

;函数功能：计算距离
(defun a1611132 (&ss1 @p1 cd1 / &ss1 &ss2 @p1 cd1 x)
(setq &ss1 (mapcar '(lambda (x) (list (distance @p1 (vlax-curve-getStartPoint x)) (distance @p1 (vlax-curve-getEndPoint x)) x)) &ss1))
(if (and (setq &ss2 (mapcar 'caddr (vl-remove-if-not '(lambda (x) (or (< (car x) cd1) (< (cadr x) cd1))) &ss1))) (> (length &ss2) 1)) (setq &ss2 '()) )
(setq &ss1 (mapcar 'caddr (vl-remove-if '(lambda (x) (or (< (car x) cd1) (< (cadr x) cd1))) &ss1)))
(list (car &ss2) &ss1)
)

;函数功能：选择不封闭对象;封闭对象改变颜色
(defun a1611131 ( / &k1 &kw1 &ss1 &ss2 i x)
(setq &ss1 '() &ss2 '())
(princ "\n请选择曲线")
(if (setq &kw1 (ssget '((0 . "*LINE,CIRCLE,ARC,HELIX,ELLIPSE"))))
  (progn
   (setq i -1.0)
   (while (setq &k1 (ssname &kw1 (setq i (1+ i))))
    (if (vlax-curve-isClosed (setq &k1 (vlax-ename->vla-object &k1))) (setq &ss1 (cons &k1 &ss1)) (setq &ss2 (cons &k1 &ss2)) )
   );while
   (if (car &ss2) (mapcar '(lambda (x) (vla-put-color x 1)) &ss2) )
   (if (car &ss1) (mapcar '(lambda (x) (vla-put-color x 7)) &ss1) )
  )
)
(if (car &ss2) &ss2 nil)
)

如果对象封闭，颜色为7【白色】，如果不封闭，颜色为1【红色】。