API应用选择首尾连接线

st788796 · 发表于 2014-5-17 09:28:06

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

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

×

(defun c:tt (/ e d ss lst outlst len p1 p2 s)
(if (not **GlobleFuzz**)
(setq **GlobleFuzz** 0.01)
)
(if (and (setq e (car (xdrx_entsel
"\n拾取起始线: "
'((0 . "*line,arc,circle,ellipse"))
)
)
)
(if (setq d
(getdist
(strcat "\n误差距离<" (rtos **GlobleFuzz** 2 3) ">: ")
)
)
(setq **GlobleFuzz** d)
(setq d **GlobleFuzz**)
)
(setq ss (ssget "x" '((0 . "*line,arc,circle,ellipse"))))
)
(progn
(ssdel e ss)
(setq lst (mapcar '(lambda (x)
(list x
(vlax-curve-isclosed x)
(vlax-curve-getstartpoint x)
(vlax-curve-getendpoint x)
)
)
(xdrx_pickset->ents ss)
)
outlst (list (list e
(vlax-curve-isclosed e)
(vlax-curve-getstartpoint e)
(vlax-curve-getendpoint e)
)
)
tf t
)
(while (and lst tf)
(setq l1 (length outlst))
(foreach a outlst
(foreach b lst
(cond
((and (cadr a) (not (cadr b)))
(setq p1 (vlax-curve-getclosestpointto (car a) (caddr b))
p2 (vlax-curve-getclosestpointto (car a) (last b))
)
(if (or (equal p1 (caddr b) d)
(equal p2 (last b) d)
)
(setq outlst (cons b outlst)
tmplst (cons b tmplst)
)
)
)
((and (cadr b) (not (cadr a)))
(setq p1 (vlax-curve-getclosestpointto (car b) (caddr a))
p2 (vlax-curve-getclosestpointto (car b) (last a))
)
(if (or (equal p1 (caddr a) d)
(equal p2 (last a) d)
)
(setq outlst (cons b outlst)
tmplst (cons b tmplst)
)
)
)
((and (not (cadr a)) (not (cadr b)))
(if (or (equal (caddr a) (caddr b) d)
(equal (caddr a) (last b) d)
(equal (last a) (caddr b) d)
(equal (last a) (last b) d)
)
(setq outlst (cons b outlst)
tmplst (cons b tmplst)
)
)
)
(t)
)
)
)
(if tmplst
(foreach c tmplst
(setq lst (vl-remove c lst))
)
)
(setq tmplst nil
tf (/= l1 (length outlst))
)
)
(setq outents (mapcar 'car outlst))
(setq s (ssadd))
(foreach x outents (ssadd x s))
(sssetfirst nil s)
)
)
(princ)
)

(defun c:tt (/ e d ss lst outlst len p1 p2 s) 
  (if (not **GlobleFuzz**) 
    (setq **GlobleFuzz** 0.01) 
  ) 
  (if (and (setq e (car        (xdrx_entsel 
                          "\n拾取起始线: " 
                          '((0 . "*line,arc,circle,ellipse")) 
                        ) 
                   ) 
           ) 
           (if (setq d 
                      (getdist 
                        (strcat "\n误差距离<" (rtos **GlobleFuzz** 2 3) ">: ") 
                      ) 
               ) 
             (setq **GlobleFuzz** d) 
             (setq d **GlobleFuzz**) 
           ) 
           (setq ss (ssget "x" '((0 . "*line,arc,circle,ellipse")))) 
      ) 
    (progn 
      (ssdel e ss) 
      (setq lst           (mapcar '(lambda (x) 
                              (list x 
                                    (vlax-curve-isclosed x) 
                                    (vlax-curve-getstartpoint x) 
                                    (vlax-curve-getendpoint x) 
                              ) 
                            ) 
                           (xdrx_pickset->ents ss) 
                   ) 
            outlst (list (list e 
                               (vlax-curve-isclosed e) 
                               (vlax-curve-getstartpoint e) 
                               (vlax-curve-getendpoint e) 
                         ) 
                   ) 
            tf           t 
      ) 
      (while (and lst tf) 
        (setq l1 (length outlst)) 
        (foreach a outlst 
          (foreach b lst 
            (cond 
              ((and (cadr a) (not (cadr b))) 
               (setq p1        (vlax-curve-getclosestpointto (car a) (caddr b)) 
                     p2        (vlax-curve-getclosestpointto (car a) (last b)) 
               ) 
               (if (or (equal p1 (caddr b) d) 
                       (equal p2 (last b) d) 
                   ) 
                 (setq outlst (cons b outlst) 
                       tmplst (cons b tmplst) 
                 ) 
               ) 
              ) 
              ((and (cadr b) (not (cadr a))) 
               (setq p1        (vlax-curve-getclosestpointto (car b) (caddr a)) 
                     p2        (vlax-curve-getclosestpointto (car b) (last a)) 
               ) 
               (if (or (equal p1 (caddr a) d) 
                       (equal p2 (last a) d) 
                   ) 
                 (setq outlst (cons b outlst) 
                       tmplst (cons b tmplst) 
                 ) 
               ) 
              ) 
              ((and (not (cadr a)) (not (cadr b))) 
               (if (or (equal (caddr a) (caddr b) d) 
                       (equal (caddr a) (last b) d) 
                       (equal (last a) (caddr b) d) 
                       (equal (last a) (last b) d) 
                   ) 
                 (setq outlst (cons b outlst) 
                       tmplst (cons b tmplst) 
                 ) 
               ) 
              ) 
              (t) 
            ) 
          ) 
        ) 
        (if tmplst 
          (foreach c tmplst 
            (setq lst (vl-remove c lst)) 
          ) 
        ) 
        (setq tmplst nil 
              tf     (/= l1 (length outlst)) 
        ) 
      ) 
      (setq outents (mapcar 'car outlst)) 
      (setq s (ssadd)) 
      (foreach x outents (ssadd x s)) 
      (sssetfirst nil s) 
    ) 
  ) 
  (princ) 
)

liuyj · 发表于 2014-5-18 14:29:16

首尾相连的，不是很麻烦。能不能弄个像express里的fast select一样的功能？（fsmode模式设为on的那种情况）

st788796 · 发表于 2014-5-20 00:36:05

不明白什么意思，没用过这个fs，不过既然有了为什么还要再写？

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

[教学] API应用 选择首尾连接线

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

[教学] API应用选择首尾连接线