Sort of a beta version, I'm adding other functions related to labeling lines to it.
;;; FUNCTION
;;; labels lines with bearing and distance in dtext, and gives you a chance
;;; to edit the text at the end
;;; uses current text style and layer
;;;
;;; ARGUMENTS
;;;
;;; USAGE
;;;
;;; PLATFORMS
;;; 2000+
;;;
;;; AUTHOR
;;; Copyright© 2004 Mark S. Thomas
;;; mark.thomas@theswamp.org
;;;
;;; VERSION
;;; 1.0 Thu Jun 10, 2004 12:59:40
; Degree to Radian conversion
(defun MST-dtr (x)
(/ (* x pi) 180.0)
)
; Radian to Degree conversion
(defun MST-rtd (x)
(/ (* x 180.0) pi)
)
;
; ,-----------------------------------------------,
; | MID POINT |
; '-----------------------------------------------'
;
(defun midpt (p1 p2)
(mapcar
'(lambda (x y) (/ (+ x y) 2.0)) p1 p2
)
)
;
; ,-----------------------------------------------,
; | VARIANT TO LIST |
; '-----------------------------------------------'
;
(defun var2lst (var)
(if (= (type var) 'VARIANT)
(vlax-safearray->list
(vlax-variant-value var)
)
)
)
;
; ,-----------------------------------------------,
; | MST-entsel-name |
; '-----------------------------------------------'
;
;;; example: (setq CirObj (MST-entsel-name "\nSelect A Circle..." "AcDbCircle"))
;;; traps any errors in the function
(defun MST-entsel-name (msg objname / ent obj)
(setq ent (vl-catch-all-apply 'entsel (list msg)))
(if (and ent (not (vl-catch-all-error-p ent)))
(progn
(setq obj (vlax-ename->vla-object (car ent)))
(if (/= (vla-get-ObjectName obj) objname)
(setq obj nil)
)
)
); if
obj
); defun
;
; ,-----------------------------------------------,
; | MST-release |
; '-----------------------------------------------'
;
(defun MST-release (obj /)
(if
(= (type obj) 'VLA-OBJECT)
(if (not (vlax-object-released-p obj))
(vlax-release-object obj)
)
)
)
(defun MST-get-txt-style ()
(vla-get-ActiveTextStyle
(vla-get-activedocument
(vlax-get-acad-object)
)
)
)
(defun MST-get-mspace ()
(vla-get-modelspace
(vla-get-activedocument
(vlax-get-acad-object)
)
)
)
;
; ,-----------------------------------------------,
; | MAIN FUNCTION |
; '-----------------------------------------------'
;
(defun LineLabel (/ th *error* ent lineObj lenD
ang bear mp txtrot p1 p2 len)
; error function
(defun *error* (msg)
(if
(not
(member msg '("console break" "Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
); if
(princ)
);end error function
(setq th (vla-get-height (MST-get-txt-style)))
(if
(<= th 0.0)
(setq th (getvar' textsize))
)
(if
(not
(setq lineobj (MST-entsel-name "\nSelect line to be measured..." "AcDbLine"))
)
(exit)
)
(setq lenD (strcat (rtos (vla-get-length lineobj) 2 2)))
(setq ang (vla-get-angle lineObj))
; determine text rotation
(cond
((and
(>= ang (* 0.5 pi)) ;between N-0°W
(< ang (* 0.538889 pi))) ;& N-20°W
(setq txtrot (- ang pi))
)
((and
(> ang (* 0.538889 pi)) ;between N-20°W
(<= ang (* 1.5 pi))) ;& S-0°W
(setq txtrot (+ ang pi))
)
((and
(>= ang (* 1.5 pi)) ;between S-0°E
(< ang (* 1.538889 pi))) ;between S-20°E
(setq txtrot (- ang pi))
)
(T
(setq txtrot ang)
)
); cond
(setq bear (vl-string-subst (chr 176) "d" (angtos ang 4 4)))
; midpoint of line
(setq mp (vlax-3d-point
(midpt
(var2lst (vla-get-startpoint lineObj))
(var2lst (vla-get-endpoint lineObj))
)
)
)
; offset points
; (setq p1
; (vlax-3d-point
; (polar (var2lst mp) (MST-dtr (+ (MST-rtd ang) 90)) (* th 2))
; )
; p2
; (vlax-3d-point
; (polar (var2lst mp) (MST-dtr (- (MST-rtd ang) 90)) (* th 2))
; )
; )
; text label bearing
(if mp
(setq txtobj
(vla-addtext
(MST-get-mspace)
(strcat bear " " lenD)
mp
th
)
)
)
(if txtobj
(progn
(vlax-put-property txtobj 'Alignment acAlignmentBottomCenter)
(vlax-put-property txtobj 'TextAlignmentPoint mp)
(vlax-put-property txtobj 'Rotation txtrot)
)
)
(MST-release txtobj)
(setq kwd
(strcase
(getstring "\nEdit bearing? (Y/N) <No>: ")
)
)
(if kwd
(if (= kwd "Y")
(command "_.ddedit" (entlast)"")
)
)
(princ)
)
(princ "\nUse 'LA' to label LINES")
(defun c:la () (LineLabel))
(princ)
