[编程交流] 引用外部圆

(defun c:dimouterboundcircles ( / unique adoc dim spc s i ci p pl d plbound plboundd plround plr a plroundd pp aa plroundorth plroundorthrem )
 (vl-load-com)
 (defun unique ( l )
   (if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 2.5e-2))) l))))
 )
 (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
 (if (= 8 (logand 8 (getvar 'undoctl)))
   (vla-endundomark adoc)
 )
 (vla-startundomark adoc)
 (setq dim (vla-get-activedimstyle adoc))
 (vla-copyfrom dim adoc)
 (setq spc (vla-get-block (vla-get-activelayout adoc)))
 (prompt "\nSelect CIRCLES...")
 (setq s (ssget '((0 . "CIRCLE"))))
 (if s
   (progn
     (repeat (setq i (sslength s))
       (setq ci (ssname s (setq i (1- i))))
       (setq p (cdr (assoc 10 (entget ci))))
       (setq pl (cons p pl))
     )
     (setq pl (mapcar (function (lambda ( p ) (trans p 0 1))) pl))
     (setq pl (vl-sort pl (function (lambda ( a b ) (if (equal (car a) (car b) 2.5e-2) (< (cadr a) (cadr b)) (< (car a) (car b)))))))
     (setq p (car pl))
     (setq d (distance p (cadr (vl-sort pl (function (lambda ( a b ) (< (distance a p) (distance b p))))))))
     (foreach p pl
       (if
         (not
           (and
             (vl-some (function (lambda ( x ) (equal x (mapcar '+ p (list d 0 0)) 2.5e-2))) pl)
             (vl-some (function (lambda ( x ) (equal x (mapcar '+ p (list (- d) 0 0)) 2.5e-2))) pl)
             (vl-some (function (lambda ( x ) (equal x (mapcar '+ p (list 0 d 0)) 2.5e-2))) pl)
             (vl-some (function (lambda ( x ) (equal x (mapcar '+ p (list 0 (- d) 0)) 2.5e-2))) pl)
           )
         )
         (setq plbound (cons p plbound))
       )
     )
     (while plbound
       (setq plbound (vl-sort plbound (function (lambda ( a b ) (if (equal (car a) (car b) 2.5e-2) (< (cadr a) (cadr b)) (< (car a) (car b)))))))
       (setq plbound (reverse (cons (car plbound) (reverse plbound))))
       (while (and (setq p (car plbound)) (not (equal p (last plround) 2.5e-2)))
         (if plround
           (setq aa (angle (car plround) p))
         )
         (if (and aa (equal aa (* 2 pi) 2.5e-2))
           (setq aa 0.0)
         )
         (setq plbound (cdr plbound))
         (setq plbound (vl-sort plbound (function (lambda ( a b ) (< (distance a p) (distance b p))))))
         (if (or (equal p (car plbound) 2.5e-2) (equal (car plbound) (car plround) 2.5e-2))
           (setq plbound (cdr (reverse (cons (car plbound) (reverse plbound)))))
         )
         (setq plboundd (vl-remove-if-not (function (lambda ( x ) (equal (distance p x) d 2.5e-2))) (vl-remove-if (function (lambda ( x ) (vl-some (function (lambda ( y ) (equal x y 2.5e-2))) plround))) plbound)))
         (setq plboundd (vl-sort plboundd (function (lambda ( a b ) (if (or (equal (angle p a) aa 2.5e-2) (and (equal (angle p a) (* 2 pi) 2.5e-2) (= aa 0.0))) t nil)))))
         (if plboundd
           (progn
             (setq plbound (vl-remove (car plboundd) plbound))
             (setq plbound (cons (car plboundd) plbound))
           )
         )
         (setq plround (cons p plround))
       )
       (setq plround (cons (car plbound) plround))
       (setq plbound (cdr plbound))
       (setq plround (reverse plround))
       (setq plr pl)
       (foreach p plround
         (setq plr (vl-remove p plr))
       )
       (while (setq p (car plround))
         (setq a (if (cadr plround) (angle p (cadr plround))))
         (if
           (not
             (or
               (equal a 0.0 2.5e-2)
               (equal a (* 0.5 pi) 2.5e-2)
               (equal a pi 2.5e-2)
               (equal a (* 1.5 pi) 2.5e-2)
               (equal a (* 2 pi) 2.5e-2)
             )
           )
           (progn
             (setq plroundorth (cons p plroundorth))
             (setq plround (cdr plround))
             (if plround
               (progn
                 (setq plroundd (vl-sort plr (function (lambda ( a b ) (< (distance a (car plround)) (distance b (car plround)))))))
                 (setq plroundd (vl-remove-if-not (function (lambda ( x ) (equal (distance x (car plround)) d 2.5e-2))) plroundd))
                 (foreach pp plroundd
                   (setq a (angle p pp))
                   (if
                     (or
                       (equal a 0.0 2.5e-2)
                       (equal a (* 0.5 pi) 2.5e-2)
                       (equal a pi 2.5e-2)
                       (equal a (* 1.5 pi) 2.5e-2)
                       (equal a (* 2 pi) 2.5e-2)
                     )
                     (setq plround (cons pp plround))
                   )
                 )
               )
             )
             (cond
               ( (and (null a) plround)
                 (setq plroundorth (cons (car plround) plroundorth))
                 (setq plround nil)
               )
               ( (and (null a) (null plround))
                 (if (not (equal (distance (car plroundorth) (last plroundorth)) d 2.5e-2))
                   (progn
                     (setq plroundd (vl-sort plr (function (lambda ( a b ) (< (distance a (car plroundorth)) (distance b (car plroundorth)))))))
                     (setq plroundd (vl-remove-if-not (function (lambda ( x ) (equal (distance x (car plroundorth)) d 2.5e-2))) plroundd))
                     (foreach pp plroundd
                       (setq a (angle p pp))
                       (if
                         (or
                           (equal a 0.0 2.5e-2)
                           (equal a (* 0.5 pi) 2.5e-2)
                           (equal a pi 2.5e-2)
                           (equal a (* 1.5 pi) 2.5e-2)
                           (equal a (* 2 pi) 2.5e-2)
                         )
                         (setq plroundorth (cons pp plroundorth))
                       )
                     )
                   )
                 )
               )
             )
           )
           (progn
             (setq plround (cdr plround))
             (while (and plround (if (or (equal a 0.0 2.5e-2) (equal a (* 2 pi) 2.5e-2)) (or (equal 0.0 (angle p (car plround)) 2.5e-2) (equal (* 2 pi) (angle p (car plround)) 2.5e-2)) (equal a (angle p (car plround)) 2.5e-2)))
               (setq pp (car plround))
               (setq plround (cdr plround))
             )
             (if (or (equal a (angle p pp) 2.5e-2) (and (equal a 0.0 2.5e-2) (equal (angle p pp) (* 2 pi) 2.5e-2)) (and (equal a (* 2 pi) 2.5e-2) (equal (angle p pp) 0.0 2.5e-2)))
               (progn
                 (if (not (vl-position p plroundorth))
                   (setq plroundorth (cons p plroundorth))
                 )
                 (setq plroundd (vl-sort plr (function (lambda ( a b ) (< (distance a pp) (distance b pp))))))
                 (setq plroundd (vl-remove-if-not (function (lambda ( x ) (equal (distance x pp) d 2.5e-2))) plroundd))
                 (foreach ppp plroundd
                   (setq aa (angle p ppp))
                   (if (and (not (equal p ppp 2.5e-2)) (not (equal pp ppp 2.5e-2)) (or (equal a aa 2.5e-2) (and (equal aa 0.0 2.5e-2) (equal a (* 2 pi) 2.5e-2)) (and (equal aa (* 2 pi) 2.5e-2) (equal a 0.0 2.5e-2))))
                     (setq plround (cons ppp plround) tst t)
                   )
                 )
                 (if (and plround (null tst))
                   (setq plround (cons pp plround))
                 )
                 (if (null plround)
                   (if (and (not (equal (angle (car plroundorth) pp) (angle (car plroundorth) (last plroundorth)) 2.5e-2)) (not (or (and (equal (angle (car plroundorth) pp) 0.0 2.5e-2) (equal (angle (car plroundorth) (last plroundorth)) (* 2 pi) 2.5e-2)) (and (equal (angle (car plroundorth) pp) (* 2 pi) 2.5e-2) (equal (angle (car plroundorth) (last plroundorth)) 0.0 2.5e-2)))) (not (vl-position pp plroundorth)))
                     (setq plround (cons pp plround))
                   )
                 )
                 (setq tst nil)
               )
               (progn
                 (setq plroundd (vl-sort plr (function (lambda ( a b ) (< (distance a pp) (distance b pp))))))
                 (setq plroundd (vl-remove-if-not (function (lambda ( x ) (equal (distance x pp) d 2.5e-2))) plroundd))
                 (foreach ppp plroundd
                   (setq aa (angle p ppp))
                   (if
                     (or
                       (equal aa 0.0 2.5e-2)
                       (equal aa (* 0.5 pi) 2.5e-2)
                       (equal aa pi 2.5e-2)
                       (equal aa (* 1.5 pi) 2.5e-2)
                       (equal aa (* 2 pi) 2.5e-2)
                     )
                     (setq plround (cons ppp plround))
                   )
                 )
               )
             )
           )
         )
       )
       (setq plroundorth (reverse plroundorth))
       (setq plroundorth (mapcar (function (lambda ( p ) (trans p 1 0))) plroundorth))
       (setq plroundorth (unique plroundorth))
       (setq plroundorthrem (vl-remove nil (mapcar (function (lambda ( a b c ) (if (equal (distance a c) (+ (distance a b) (distance b c)) 2.5e-2) b))) plroundorth (cdr (reverse (cons (car plroundorth) (reverse plroundorth)))) (cddr (reverse (cons (cadr plroundorth) (cons (car plroundorth) (reverse plroundorth))))))))
       (foreach p plroundorthrem
         (setq plroundorth (vl-remove p plroundorth))
       )
       (mapcar (function (lambda ( a b ) (vla-adddimaligned spc (vlax-3d-point a) (vlax-3d-point b) (vlax-3d-point (mapcar '/ (mapcar '+ a b) (list 2.0 2.0 2.0)))))) plroundorth (cdr (reverse (cons (car plroundorth) (reverse plroundorth)))))
       (setq plround nil plroundorth nil)
     )
   )
 )
 (vla-endundomark adoc)
 (princ)
)

(setq ss (ssget (list (cons 0 "Circle"))))
(setvar "osmode" 0)
(setq tot 0)
(repeat (setq x (sslength ss))
(setq obj (vlax-ename->vla-object (ssname SS (setq x (- x 1)))))
(setq cenpt (vlax-safearray->list (vlax-variant-value (vla-get-center obj))))
(setq rad (* 3.2 (vla-get-radius obj)))
(setq pt1 (polar cenpt (/ pi 4.0) rad))
(setq pt2 (polar cenpt (* pi 1.5) rad))
(command "_.line" pt1 pt2 "") ; for testing
(setq ss2 (ssget "_w" pt1 pt2))
(if (and (/= ss2 nil)(< (sslength ss2) )
(setq tot (+ Tot 1)) ; this is external circles
)
(princ (strcat "\n" (rtos tot 2 0)))
(setq ss2 nil)
)

3