[编程交流] 标签轮廓Lisp帮助

(defun alg-ang (obj pnt)
 (angle '(0. 0. 0.)
 (vlax-curve-getfirstderiv
   obj
   (vlax-curve-getparamatpoint
     obj
     pnt
   )
 )
 )
)
(defun C:LABCONT (/     ang   angp         box   dv    en           ent         p1    p2
       p3    p4           pt         txten txthgt           txtpt wid   zstr
       zvalue
      )
 (setvar "osmode" 512)
   (setvar "cmdecho" 0)
 (COMMAND "_layer" "_m" "Contours Elev" "_c" "2" "" "_lw" "0.30" "" "")
 (command"textmask" "M" "W")
    (setq scl (getvar "useri1"))
    (setq ht (* 0.0025 scl))
 (setq        txthgt ht                        ;<-- text height
  gap (/ txthgt 9999));<-- change gap here                                        
 (if
   (setq ent (entsel "\nSelect contour line >>"))
    (progn
      (setq en (car ent))
      (while (setq pt
             (getpoint
               "\nPick a point on the contour (or press Enter to Exit) >> "
             )
      )
 (setq pt     (vlax-curve-getclosestpointto en pt)
       zvalue (caddr pt)
       zstr   (rtos zvalue 2 2)
       dv     (vlax-curve-getfirstderiv
                en
                (vlax-curve-getparamatpoint en pt)
              )
       ang    (alg-ang en pt)
       ang
              (cond ((< (/ pi 2) ang (* pi 1.5)) (+ pi ang))
                    (T ang)
              )
       angp   (+ (/ pi 2) ang)
       txtpt  (polar pt angp gap)
 )
 (entmake
   (list
     '(0 . "TEXT")
     '(100 . "AcDbEntity")
     (cons 67
           (if (= 0 (getvar "tilemode"))
             1
             0
           )
     )
     (cons 410 (getvar "ctab"))
    ; '(8 . "Contours Elev")        ;<-- layer for texts
     '(100 . "AcDbText")
     (cons 10 txtpt)
     (cons 11 txtpt)
     (cons 40 txthgt)
     (cons 1 zstr)
     (cons 50 ang)
     '(41 . 1.0)
     '(51 . 0.0)
     '(7 . "POINTS")                ;<-- text style
     '(71 . 0)
     '(72 . 1)
     '(73 . 2)
   )
 )
 (princ)
      )
      (vl-load-com)
    )
 )
)

(vlax-put-property text 'BackgroundFill :vlax-true)