[编程交流] 链测长度lisp到等高线标签

(defun c:cr (/)
(vl-load-com)
(defun _Line (p b o)
      (entmake
 (append
   '((0 . "line")
     (100 . "AcDbEntity")
     (67 . 0)
     (410 . "Model")
     (8 . "C-CTRL_TICK")
     (100 . "AcDbLine")
     )
   (list (cons 10 (polar p b o)))
   (list (cons 11 (polar p (+ b PI) o)))
   '((210 0.0 0.0 1.0))
   )
 )
 )
(defun _text (p b o h c)
      (entmake
 (append
   '((0 . "MTEXT")
     (100 . "AcDbEntity")
     (67 . 0)
     (410 . "Model")
     (8 . "C-CTRL_TXT")
     (100 . "AcDbMText")
     )
   (list (cons 10 (polar p (+ b PI) o))
  )
   (list (cons 40 h))
   (list (cons 1 (strcat "CH "
    (if (setq ld (nth (strlen (rtos  c 3 0)) '(x   "")))
       ld "")
    (rtos c 2 2))))
   (list (cons 50 (+ b PI)))
     (list '(41 . 0)
     '(90 . 3)
     '(63 . 256)
     '(441 . 3935927) 
     '(71 . 4)
     '(72 . 5)
     (cons 7 (getvar "textstyle"))
     '(210 0.0 0.0 1.0)
     '(73 . 1)
     )
   )
 )
 )
(defun _ang (p1 p2)(+ (angle p1 p2) (/ PI 2.0)))
(setq dist (getdist "increment: "))
 (setq offset (getdist "tick size: "))
 (setq height (getdist "text height: "))
 (setq to (getdist "text offset: "))
 (setq ss (ssget)
count 0
dist dist
offset offset
height height
)
 (repeat (sslength ss)
   (setq ent    (ssname ss count)
  obj    (vlax-ename->vla-object ent)
  chainage dist
  )
   (_line (setq p (vlax-curve-getstartpoint obj))
   (setq bearing (_ang p (vlax-curve-getPointAtDist obj (+ chainage 0.001))))
    offset)
   (_text p bearing to height 0.0)
   (while
     (and
(setq point1 (vlax-curve-getPointAtDist obj chainage))
(setq point2 (vlax-curve-getPointAtDist obj (+ chainage 0.001)))
)
      (setq bearing (+ (angle point1 point2) (/ PI 2.0)))
      (_line point1 bearing offset)
      (_text point1 bearing to height chainage)
      (setq chainage (+ chainage dist))
      )
   (setq count (1+ count))
   )
 )

;;;;;CONTOUR LABELING;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;based on chainage lisp posted by sean.keohane ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:cl (/)
(vl-load-com)
(defun _text (p b o h c)
(entmake
 (append
   '((0 . "MTEXT")
     (100 . "AcDbEntity")
     (67 . 0)
     (410 . "Model")
     (8 . "C-CTRL_TXT")
     (100 . "AcDbMText")
     )
   (list (cons 10 (polar p (+ b PI) o))
  )
   (list (cons 40 h))
   (list (cons 1 (strcat ""(if (setq ld (nth (strlen (rtos  c 2 0)) '(x   "")))ld "")(rtos c 2 0))));<--:Elevation Value;;;
     (list (cons 50 (+ b (/ pi 2))));<--Rotation angle of text;;
   
     (list '(41 . 0)
     '(90 . 3);<-- Mask
     '(63 . 256);<--Mask
     '(441 . 3935927);<-- Mask 
     '(71 . 5);<--Justification:Middle Center;;
     '(72 . 5)
     (cons 7 (getvar "textstyle"));<--:Current text style;;
     '(210 0.0 0.0 1.0)
     '(73 . 3)
     )
   )
 )
 )
(defun _ang (p1 p2)(+ (angle p1 p2) (/(* 3 PI) 2.0)))
(setq dist (cond ((getdist "increment <400>:"))(400)));<--:Contour Label Increment;;
(setq offset 0)
(setq height 2.5);<--:default text height;;
(setq to 0)
(setq ss (ssget)
count 0
dist dist
offset offset
height height
)
(repeat (sslength ss)
(setq ent (ssname ss count)
  obj (vlax-ename->vla-object ent)
  chainage dist)
  
   (_text p bearing to height (caddr p))
   (while
     (and
(setq point1 (vlax-curve-getPointAtDist obj chainage))
(setq point2 (vlax-curve-getPointAtDist obj (+ chainage 0.001)))
)
      (setq bearing (+ (angle point1 point2) (/(* 3 PI )2.0)))
      (_text point1 bearing to height (caddr point1))
      
      (setq chainage (+ chainage dist))
      )
   (setq count (1+ count))
   )
 )

(_text p [color=red]bearing[/color] to height (caddr p))

(setq bearing (+ (angle point1 point2) (/(* 3 PI )2.0)))

;;;    (_text p bearing to height (caddr p)) <--- [color="red"]try to remove this line[/color]
   (while
     (and
...
...