API测试检查悬挂点

st788796 · 发表于 2013-11-28 01:06:03

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

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

×

本帖最后由 st788796 于 2013-11-28 12:47 编辑

改编自 eachy 副站长程序，同等替换，未作测试！

(defun c:Chkopen (/ RemoveDups diff box pl)
(defun RemoveDups (pts fuzz / ll)
(setq ll (list (car pts)))
(while (setq pts (cdr pts))
(setq pts (vl-remove-if
'(lambda (x) (equal (car x) (caar ll) fuzz))
pts
)
ll (cons (car pts) ll)
)
)
ll
)
(gc)
(princ "\n选择Line,Pline,Arc,Spline,Ellipse...")
(XD::Doc:DisableOsmode)
(if (setq ss (ssget '((0 . "*line,arc,ellipse"))))
(progn
(princ "\nPlease Waiting, Checking.....")
(setq diff (/ 1. 64)
box (xdrx_entity_box ss)
pl (mapcar '(lambda (x)
(list (list (xdrx_curve_getstartpoint x) x)
(list (xdrx_curve_getendpoint x) x)
)
)
(vl-remove-if
'(lambda (c) (xdrx_curve_isclosed c))
(xdrx_pickset->ents ss)
)
)
)
(if (apply 'xdrx_document_isptoutscreen box)
(xdrx_document_zoomw (car box) (nth 2 box))
)
(if (setq pl (RemoveDups pl diff))
(setq
pl (vl-remove
't
(mapcar
'(lambda (x / s sl e p)
(setq p (car x)
e (cadr x)
)
(if (and (setq s
(ssget
":E"
'((0
.
"line,lwpolyline,polyline,spline,circle,arc,ellipse"
)
)
)
)
(ssdel e s)
(> (sslength s) 0)
)
(if
(> (car
(vl-sort
(mapcar
'(lambda (x)
(distance
(xdrx_curve_getclosestpoint x p)
p
)
)
(xdrx_pickset->ents s)
)
'<
)
)
diff
)
t
)
p
)
)
pl
)
)
)
(if (setq pl (vl-remove 'nil pl))
(progn
(xdrx_layer_make "XD_mark_open" 1)
(xdrx_setmark)
(mapcar '(lambda (x / c)
(setq c (xdrx_circle_make x 1.))
(xdrx_setpropertyvalue c "layer" "XD_mark_open")
)
pl
)
(xdrx_group_make "*" (xdrx_getss))
(setvar "PICKSTYLE" 1)
(sssetfirst nil (ssget "L"))
)
(princ "\n......OK!.....")
)
)
)
)
(XD::Doc:EnableOsmode)
(princ)
)

(defun c:Chkopen (/ RemoveDups diff box pl) 
  (defun RemoveDups (pts fuzz / ll) 
    (setq ll (list (car pts))) 
    (while (setq pts (cdr pts)) 
      (setq pts        (vl-remove-if 
                  '(lambda (x) (equal (car x) (caar ll) fuzz)) 
                  pts 
                ) 
            ll        (cons (car pts) ll) 
      ) 
    ) 
    ll 
  ) 
  (gc) 
  (princ "\n选择Line,Pline,Arc,Spline,Ellipse...")   
  (XD::Doc:DisableOsmode) 
  (if (setq ss (ssget '((0 . "*line,arc,ellipse")))) 
    (progn 
      (princ "\nPlease Waiting, Checking.....") 
      (setq diff (/ 1. 64) 
            box         (xdrx_entity_box ss) 
            pl         (mapcar '(lambda (x) 
                            (list (list (xdrx_curve_getstartpoint x) x) 
                                  (list (xdrx_curve_getendpoint x) x) 
                            ) 
                          ) 
                         (vl-remove-if 
                           '(lambda (c) (xdrx_curve_isclosed c)) 
                           (xdrx_pickset->ents ss) 
                         ) 
                 ) 
      ) 
      (if (apply 'xdrx_document_isptoutscreen box) 
        (xdrx_document_zoomw (car box) (nth 2 box)) 
      ) 
      (if (setq pl (RemoveDups pl diff)) 
        (setq 
          pl (vl-remove 
               't 
               (mapcar 
                 '(lambda (x / s sl e p) 
                    (setq p (car x) 
                          e (cadr x) 
                    ) 
                    (if        (and (setq s 
                                    (ssget 
                                      ":E" 
                                      '((0 
                                         . 
                                         "line,lwpolyline,polyline,spline,circle,arc,ellipse" 
                                        ) 
                                       ) 
                                    ) 
                             ) 
                             (ssdel e s) 
                             (> (sslength s) 0) 
                        ) 
                      (if 
                        (> (car 
                             (vl-sort 
                               (mapcar 
                                 '(lambda (x) 
                                    (distance 
                                      (xdrx_curve_getclosestpoint x p) 
                                      p 
                                    ) 
                                  ) 
                                 (xdrx_pickset->ents s) 
                               ) 
                               '< 
                             ) 
                           ) 
                           diff 
                        ) 
                         t 
                      ) 
                      p 
                    ) 
                  ) 
                 pl 
               ) 
             ) 
        ) 
        (if (setq pl (vl-remove 'nil pl)) 
          (progn 
            (xdrx_layer_make "XD_mark_open" 1) 
            (xdrx_setmark) 
            (mapcar '(lambda (x / c) 
                       (setq c (xdrx_circle_make x 1.)) 
                       (xdrx_setpropertyvalue c "layer" "XD_mark_open") 
                     ) 
                    pl 
            ) 
            (xdrx_group_make "*" (xdrx_getss)) 
            (setvar "PICKSTYLE" 1) 
            (sssetfirst nil (ssget "L"))             
          ) 
          (princ "\n......OK!.....") 
        ) 
      ) 
    ) 
  ) 
  (XD::Doc:EnableOsmode) 
  (princ) 
)

Lisphk · 发表于 2013-11-28 09:24:58

悬挂点是什么，大师？

账号		自动登录	找回密码
密码			立即注册

[每日一码] API测试检查悬挂点

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

浏览过的版块

[每日一码] API测试 检查悬挂点

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

浏览过的版块

[每日一码] API测试检查悬挂点