[编程交流] 标记点X、Y、Z

(defun c:test ( / *error* eea-cpp-6-2d getpoints nthmassocsubst ucsf fn pl p1p2 d le xdata assocl xdatan )
 (defun *error* ( msg )
   (if ucsf
     (command "_.UCS" "_P")
   )
   (if msg
     (prompt msg)
   )
   (princ)
 )
 (defun eea-cpp-6-2d (l / D D1 I Q)
                  ;|
 *****************************************************************************************
  
    by ElpanovEvgeniy
    last edit 19.07.2012
  
    the library function 
    find a pair of points with the smallest distance between them
    
 *****************************************************************************************
  
    argument - list points
    returne  - list pair points
   
    For the first time it is published
    http://www.theswamp.org/index.php?topic=40592.0
    
 *****************************************************************************************
  |;
   (setq l  (vl-sort l (function (lambda (a b) (<= (car a) (car b)))))
         d  (distance (list (caar l) (cadar l)) (list (caadr l) (cadadr l)))
         d1 (+ d 1e-
         q  nil
         i  -1
   )
   (if (and (nth 200 l)
            (progn (repeat 20 (setq q (cons (nth (setq i (1+ i)) l) q)))
                   (apply (function <=)
                          (mapcar (function -)
                                  (apply (function mapcar) (cons (function max) q))
                                  (apply (function mapcar) (cons (function min) q))
                                  '(0 0)
                          )
                   )
            )
       )
     (defun f (p l / di)
       (while (and l (equal (cadr p) (cadar l) d1))
         (cond ((equal (setq di (distance (list (car p) (cadr p)) (list (caar l) (cadar l)))) d 1e- (setq q (cons (list p (car l)) q)))
               ((< di d)
                (setq d  di
                      d1 (+ d 1e-
                      q  (list (list p (car l)))
                )
               )
         )
         (setq l (cdr l))
       )
     )
     (defun f (p l / di)
       (while (and l (equal (car p) (caar l) d1))
         (cond ((equal (setq di (distance (list (car p) (cadr p)) (list (caar l) (cadar l)))) d 1e- (setq q (cons (list p (car l)) q)))
               ((< di d)
                (setq d  di
                      d1 (+ d 1e-
                      q  (list (list p (car l)))
                )
               )
         )
         (setq l (cdr l))
       )
     )
   )
   (foreach a l (f a (cdr l)) (setq l (cdr l)))
   (list d q)
 )
 (defun getpoints ( ss / i l a b c )
   (if ss
     (repeat (setq i (sslength ss))
       (setq a (ssname ss (setq i (1- i))))
       (setq b (entget a))
       (setq c (cdr (assoc 10 b)))
       (setq l (cons c l))
     )
   )
   l
 )
 (defun nthmassocsubst ( n key value lst / k slst p j plst m tst pslst )
   (setq k (length (setq slst (member (assoc key lst) lst))))
   (setq p (- (length lst) k))
   (setq j -1)
   (repeat p
     (setq plst (cons (nth (setq j (1+ j)) lst) plst))
   )
   (setq plst (reverse plst))
   (setq j -1)
   (setq m -1)
   (repeat k
     (setq j (1+ j))
     (if (equal (assoc key (member (nth j slst) slst)) (nth j slst) 1e-6)
       (setq m (1+ m))
     )
     (if (and (not tst) (= n m))
       (setq pslst (cons (cons key value) pslst) tst t)
       (setq pslst (cons (nth j slst) pslst))
     )
   )
   (setq pslst (reverse pslst))
   (append plst pslst)
 )
 (if (eq (getvar 'worlducs) 0)
   (progn
     (command "_.UCS" "_W")
     (setq ucsf t)
   )
 )
 (if (not (tblsearch "BLOCK" "label leader"))
   (if (findfile "label leader.dwg")
     (progn
       (command "_.-INSERT" "label leader.dwg" "_non" '(0.0 0.0 0.0))
       (while (< 0 (getvar 'cmdactive)) (command ""))
       (entdel (entlast))
     )
     (progn
       (setq fn (getfiled "Select "label leader.dwg" file..." "\" "dwg" 16))
       (command "_.-INSERT" fn "_non" '(0.0 0.0 0.0))
       (while (< 0 (getvar 'cmdactive)) (command ""))
       (entdel (entlast))
     )
   )
 )
 (if (setq pl (getpoints (ssget '((0 . "POINT")))))
   (progn
     (setq p1p2 (caadr (eea-cpp-6-2d pl)))
     (setq d (distance (list (caar p1p2) (cadar p1p2)) (list (caadr p1p2) (cadadr p1p2))))
     (foreach p pl
       (command "_.-INSERT" "label leader" "_non" p d)
       (while (< 0 (getvar 'cmdactive)) (command ""))
       (command "_.EXPLODE" (entlast))
       (while (< 0 (getvar 'cmdactive)) (command ""))
       (setq le (car (vl-remove-if-not '(lambda ( x ) (eq (cdr (assoc 0 (entget x))) "LEADER")) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_P")))))))
       (setq xdata (assoc -3 (entget le '("*"))))
       (setq assocl (cdr (cadr xdata)))
       (setq assocl (nthmassocsubst 0 1040 (* (cdr (assoc 1040 assocl)) d) assocl))
       (setq xdatan (list -3 (cons "ACAD" assocl)))
       (entupd (cdr (assoc -1 (entmod (subst xdatan xdata (entget le '("*"))))))) 
     )
   )
 )
 (command "_.-PURGE" "_B" "label leader" "_N")
 (while (< 0 (getvar 'cmdactive)) (command ""))
 (*error* nil)
)