标签轮廓Lisp帮助
嗨，我有这个标签轮廓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)
)
)
)
ymg公司 Any other options?
Thanks prodromosm,
If you look in my TIN program there is three different way to label the contours.
The various way I used were heavily derived from an offering by Alan J Thompson.
ymg Can any one tell me how add mask a text in the code ? prodromosm,
You just set on the BackgroundFill property to true on an MTEXT object.
(vlax-put-property text 'BackgroundFill :vlax-true)
ymg
页:
[1]