[编程交流] 共享数字维度

;;bbs.mjtd.com
;;Author:SunSpring
(vl-load-com)
(setq *number* 1)
(defun makeleader (lst)
 (if (> (length lst) 1)
   (entmakex (append
            (list '(0 . "LEADER") '(100 . "AcDbEntity") '(100 . "AcDbLeader"))
            (mapcar '(lambda (pt) (cons 10 pt)) lst)
          )
   )
 )
)
(defun entlist (ss / enlst ent lst n x)
 (cond
   ((= (type ss) 'pickset)
     (repeat (setq n (sslength ss))
       (setq ent (ssname ss (setq n (1- n))))
       (setq lst (cons ent lst))
     )
     lst
   )
   ((= (type ss) 'list)
     (setq enlst (ssadd))
     (foreach x ss
       (if (= (type x) 'ename)
         (ssadd x enlst)
       )
     )
     enlst
   )
 )
)

(defun delgrp (entgrp)
 (if (= (type entgrp) 'ename)
   (setq entgrp (ssadd entgrp))
 )
 (if entgrp
   (mapcar 'entdel (entlist entgrp))
   ;(mapcar 'vla-delete (vobjlist entgrp))
 )
)

(defun lt:ss-entnext (en / ss)
 (if en
   (progn
     (setq ss (ssadd))
     (while (setq en (entnext en))
       (if (not (member (cdr (assoc 0 (entget en)))
                        '("ATTRIB" "VERTEX" "SEQEND")
                )
           )
         (ssadd en ss)
       )
     )
     (if (zerop (sslength ss)) (setq ss nil))
     ss
   )
   (ssget "_x")
 )
)

(defun maketext (locationpoint textheight text rowtype)
 (entmakex (list '(0 . "TEXT")
                '(100 . "AcDbText")
                 (cons 40 textheight)
                '(41 . 0.
                 (cons 1 text)
                 (cons 72 rowtype)
                '(10 0.0 0.0 0.0)
                 (cons 11 (trans locationpoint 1 0))
                '(73 . 2)
          )
 )
)

(defun makeline (start_point end_point)
 (entmakex (list '(0 . "line")
                (cons 10 (trans start_point 1 0))
                (cons 11 (trans end_point 1 0))
          )
 )
)

(defun getmidpoint (p1 p2)
 (mapcar '(lambda (x) (/ x 2)) (mapcar '+ p1 p2))
)
(defun c:cba ( / #errexit $orr ang bpt ent gr lastent n num number pp1 pp2 pp3 pp4 pt1 pt2 sxlen textheight textline zxlen)
 (defun #errexit (s)
   (delgrp (lt:ss-entnext lastent))
   (setq *error* $orr)
 )
 (setq $orr *error*)
 (setq *error* #errexit)
 (setq lastent (entlast))
 (princ "\nPlease input the starting number :<")
 (princ *number*)
 (if (setq number (getint ">:"))
   (setq *number* number)
 )
 (while (setq pt1 (getpoint "\nSpecify the starting point : "))
   ;(titleplace pt1)
   (cond
     ((= (getvar "textsize") 3.5)
       (setq textheight (* (getvar "dimscale") 5))
     )
     ((= (getvar "textsize") 5)
       (setq textheight (* (getvar "dimscale") 7))
     )
   )
   (setq textline (* 2 textheight))
   (setq zxlen (* 0.25 textline))
   (setq sxlen (* 2 textheight))
   (setq local (* 0.7 textheight))
   (setq lastent (entlast))
   (if (setq pt2 (getpoint pt1 "\nSpecify the end point: "))
     (progn
       (setq ent (makeleader (list pt1 pt2)))
       (vla-put-ArrowheadType (*en2obj* ent) acArrowDotSmall)
     )
      (exit)
   )
   (while (= (car (setq gr (grread nil 5 0))) 5)
     (delgrp (lt:ss-entnext ent))
     (setq num (/ (distance pt2 (cadr gr)) 10))
     (cond
       (
         (or
           (and
             (> (angle pt2 (cadr gr)) 0)
             (< (angle pt2 (cadr gr)) (* 0.25 pi))
           )
           (and
             (> (angle pt2 (cadr gr)) (* 1.75 pi))
             (< (angle pt2 (cadr gr)) (* 2.00 pi))
           )
         )
         (setq ang 0)
       )
       (
         (and
           (> (angle pt2 (cadr gr)) (* 0.25 pi))
           (< (angle pt2 (cadr gr)) (* 0.75 pi))
         )
         (setq ang (* 0.5 pi))
       )
       (
         (and
           (> (angle pt2 (cadr gr)) (* 0.75 pi))
           (< (angle pt2 (cadr gr)) (* 1.25 pi))
         )
         (setq ang pi)
       )
       (
         (and
           (> (angle pt2 (cadr gr)) (* 1.25 pi))
           (< (angle pt2 (cadr gr)) (* 1.75 pi))
         )
         (setq ang (* 1.5 pi))
       )
     )
     (setq n *number*)
     (if (> num 0)
       (cond
         ((= ang 0)
           (cond
             ((and (> (angle pt1 pt2) 0) (< (angle pt1 pt2) pi))
               (setq pp1 (polar pt2 ang textline))
               (makeline pt2 pp1)
               (setq bpt (polar (getmidpoint pt2 pp1) (+ ang (* 0.5 pi)) local))
               (maketext bpt textheight (itoa n) 1)
               (repeat (fix num)
                 (setq pp2 (polar pp1 (- ang (* 0.25 pi)) zxlen))
                 (makeline pp1 pp2)
                 (setq pp3 (polar pp2 (+ ang (* 0.25 pi)) zxlen))
                 (makeline pp2 pp3)
                 (setq pp4 (polar pp3 ang textline))
                 (makeline pp3 pp4)
                 (setq bpt (polar (getmidpoint pp3 pp4) (+ ang (* 0.5 pi)) local))
                 (maketext bpt textheight (itoa (setq n (1+ n))) 1)
                 (setq pp1 pp4)
               )
             )
             (t
               (setq n (+ n (fix num)))
               (setq pp1 (polar pt2 ang textline))
               (makeline pt2 pp1)
               (setq bpt (polar (getmidpoint pt2 pp1) (+ ang (* 0.5 pi)) local))
               (maketext bpt textheight (itoa n) 1)
               (repeat (fix num)
                 (setq pp2 (polar pp1 (- ang (* 0.25 pi)) zxlen))
                 (makeline pp1 pp2)
                 (setq pp3 (polar pp2 (+ ang (* 0.25 pi)) zxlen))
                 (makeline pp2 pp3)
                 (setq pp4 (polar pp3 ang textline))
                 (makeline pp3 pp4)
                 (setq bpt (polar (getmidpoint pp3 pp4) (+ ang (* 0.5 pi)) local))
                 (maketext bpt textheight (itoa (setq n (1- n))) 1)
                 (setq pp1 pp4)
               )
             )
           )
         )
         ((= ang (* 0.5 pi))
           (cond
             ((and (> (angle pt1 pt2) (* 0.5 pi)) (< (angle pt1 pt2) (* 1.5 pi)))
               (setq pp1 (polar pt2 pi textline))
               (makeline pt2 pp1)
               (setq bpt (polar (getmidpoint pt2 pp1) (* 0.5 pi) local))
               (maketext bpt textheight (itoa n) 1)
               (setq pp1 pt2)
               (repeat (fix num)
                 (setq pp2 (polar pp1 ang sxlen))
                 (makeline pp1 pp2)
                 (setq pp3 (polar pp2 pi textline))
                 (makeline pp2 pp3)
                 (setq bpt (polar (getmidpoint pp2 pp3) (* 0.5 pi) local))
                 (maketext bpt textheight (itoa (setq n (1+ n))) 1)
                 (setq pp1 pp2)
               )
             )
             (t
               (setq n (+ n (fix num)))
               (setq pp1 (polar pt2 0 textline))
               (makeline pt2 pp1)
               (setq bpt (polar (getmidpoint pt2 pp1) (* 0.5 pi) local))
               (maketext bpt textheight (itoa n) 1)
               (setq pp1 pt2)
               (repeat (fix num)
                 (setq pp2 (polar pp1 ang sxlen))
                 (makeline pp1 pp2)
                 (setq pp3 (polar pp2 0 textline))
                 (makeline pp2 pp3)
                 (setq bpt (polar (getmidpoint pp2 pp3) (* 0.5 pi) local))
                 (maketext bpt textheight (itoa (setq n (1- n))) 1)
                 (setq pp1 pp2)
               )
             )
           )
         )
         ((= ang pi)
           (cond
             ((and (> (angle pt1 pt2) 0) (< (angle pt1 pt2) pi))
               (setq n (+ n (fix num)))
               (setq pp1 (polar pt2 ang textline))
               (makeline pt2 pp1)
               (setq bpt (polar (getmidpoint pt2 pp1) (- ang (* 0.5 pi)) local))
               (maketext bpt textheight (itoa n) 1)
               (repeat (fix num)
                 (setq pp2 (polar pp1 (+ ang (* 0.25 pi)) zxlen))
                 (makeline pp1 pp2)
                 (setq pp3 (polar pp2 (- ang (* 0.25 pi)) zxlen))
                 (makeline pp2 pp3)
                 (setq pp4 (polar pp3 ang textline))
                 (makeline pp3 pp4)
                 (setq bpt (polar (getmidpoint pp3 pp4) (- ang (* 0.5 pi)) local))
                 (maketext bpt textheight (itoa (setq n (1- n))) 1)
                 (setq pp1 pp4)
               )
             )
             (t
               (setq pp1 (polar pt2 ang textline))
               (makeline pt2 pp1)
               (setq bpt (polar (getmidpoint pt2 pp1) (- ang (* 0.5 pi)) local))
               (maketext bpt textheight (itoa n) 1)
               (repeat (fix num)
                 (setq pp2 (polar pp1 (+ ang (* 0.25 pi)) zxlen))
                 (makeline pp1 pp2)
                 (setq pp3 (polar pp2 (- ang (* 0.25 pi)) zxlen))
                 (makeline pp2 pp3)
                 (setq pp4 (polar pp3 ang textline))
                 (makeline pp3 pp4)
                 (setq bpt (polar (getmidpoint pp3 pp4) (- ang (* 0.5 pi)) local))
                 (maketext bpt textheight (itoa (setq n (1+ n))) 1)
                 (setq pp1 pp4)
               )
             )
           )
         )
         ((= ang (* 1.5 pi))
           (cond
             ((and (> (angle pt1 pt2) (* 0.5 pi)) (< (angle pt1 pt2) (* 1.5 pi)))
               (setq n (+ n (fix num)))
               (setq pp1 (polar pt2 pi textline))
               (makeline pt2 pp1)
               (setq bpt (polar (getmidpoint pt2 pp1) (* 0.5 pi) local))
               (maketext bpt textheight (itoa n) 1)
               (setq pp1 pt2)
               (repeat (fix num)
                 (setq pp2 (polar pp1 ang sxlen))
                 (makeline pp1 pp2)
                 (setq pp3 (polar pp2 pi textline))
                 (makeline pp2 pp3)
                 (setq bpt (polar (getmidpoint pp2 pp3) (* 0.5 pi) local))
                 (maketext bpt textheight (itoa (setq n (1- n))) 1)
                 (setq pp1 pp2)
               )
             )
             (t
               (setq pp1 (polar pt2 0 textline))
               (makeline pt2 pp1)
               (setq bpt (polar (getmidpoint pt2 pp1) (* 0.5 pi) local))
               (maketext bpt textheight (itoa n) 1)
               (setq pp1 pt2)
               (repeat (fix num)
                 (setq pp2 (polar pp1 ang sxlen))
                 (makeline pp1 pp2)
                 (setq pp3 (polar pp2 0 textline))
                 (makeline pp2 pp3)
                 (setq bpt (polar (getmidpoint pp2 pp3) (* 0.5 pi) local))
                 (maketext bpt textheight (itoa (setq n (1+ n))) 1)
                 (setq pp1 pp2)
               )
             )
           )
         )
       )
     )
   )
   (setq *number* (1+ n))
 )
 (princ)
)