Line Labeling

I need a lisp routine to label lines with surveyors Units with bearing
(N39°16'24"E 12.36')
or without a bearing (12.36').

Any Help would be greatly appreciated

Robert

 

HiHo;
I wrote this many years ago and it works with R2002.
Load and type "bd", "enter", without the "s to run.
Read the program header to see the options, Bearing/dist
above/below on or off ect.

 

HiHo;
So, I can't attached a file to this email.
Below is the program.
.............................................................................
.......................................................
;;;BD.lsp 9 Aug. 96 by Jiro
;;; Revisied by JIRO 14 May 97
;;; Revisied by Jiro 18 Nov. 2002...OSNAP Fix for R14 and up.
;;; The variable "osnapcoord" , when set to 1, will work
;;;========================================================
;;; This routine requires a FIXED HEIGHT TEXT-STYLE
;;; At the prompt "Start point:" pick a starting point,
;;; endpoint of a line, or ENTER the coordinates. OSNAPS are honored.
;;; The cmd-line display is similar to the PEDIT command.
;;; Bearing,Dist,Line,Flip,Start,stAck,eXit or pick-pt:"
;;; PRESS the following toggle's and....<ENTER> or Spacebar
;;; b will turn on/off bearings annotation
;;; and will display a Bearing on the cmd line
;;; d will turn on/off distance annotation
;;; and will display a Distance on the cmd line
;;; L will turn on/off lines drawn from Start point to pick-pt
;;; and will display a -L- on the cmd line
;;; f will "Flip" the "Bear/Dist"to "Dist/Bear"
;;; a will "stAck" "Dist Bear /" or Flip for "/ Bear Dist"
;;; s will allow you to start annotating at a new Start point,
;;; while maintaining the current status of "BDL"
;;; x will EXIT this program
;;; or pick-a-point, [ OSNAP's are honored ]
;;;
;;;========================================================
(defun c:bd (/ SumVars )
;==========================================================
(defun *error* (msg)
(princ msg)
);end defun error

;==========================================================
; Set and Save System Variables
; REMBEMBER to edit the vlist list
;==========================================================
(Defun pushvars ( )
(setq vlist
'(("cmdecho" . 0)
("aunits" . 3)
("angdir" . 0)
("angbase" . 0)
("osnapcoord" . 1);This fixes it in 2002
)
);end setq
(setq old_error *error*)
(setvar "modemacro" ".")
(ForEach pair vlist
(Setq name (Strcase (CAR pair)))
(If (Not (Assoc name sysvars))
(Setq
sysvars (Cons (Cons name (GetVar name)) sysvars)
); setq
);end if
(If (CDR pair)
(Setvar name (CDR pair))
);if
);end foreach
);end pushvars

;==========================================================
; Restore System Variables
;==========================================================
(Defun popvars ( )
(ForEach pair sysvars
(Setvar (CAR pair) (CDR pair))
)
(Setq *error* old_error)
(Setq sysvars Nil)
(setvar "modemacro" ".")
(princ)
);end popvars
;==========================================================
;;;Additional defun functions go here
;==========================================================
(defun bd_main ( / ab ad ang1 ang2 at au b bo ce d do ds entla_a entla_d f
gr l lo p1 p2 p3 s so st th to)

(if (= 0.0 (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))))
(progn
(alert "Change TEXTSTYLE\nto FixEd Height TEXT")
(pushvars)
)
)
(setq th (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE"))))
b 1.0
bo "B"
d 1.0
do "D"
l 0
lo ""
f 1.0
gr "B / D "
at 0
to ""
switch 1
)
(grtext -1 gr)
(while (= switch 1)
(setq p1(getpoint "\nStart point:"))
(grtext -1 gr)
(while p1
(if (= b 1) (setq bo " B ")
(setq bo " "))
(if (= d 1) (setq do " D ")
(setq do " "))
(if (= l 1) (setq lo " -L- ")
(setq lo " "))
(if (= at 1) (setq to "BD")
(setq to ""))
(if (= f 1)
(if (= to "") (setq gr (strcat bo "/" do lo))
(setq gr (strcat do bo "/" lo))
);if
(if (= to "") (setq gr (strcat do "/" bo lo))
(setq gr (strcat "/" bo do lo))
);if
);if
(grtext -1 gr)
(initget 1 "B D L F S A X")
(setq p2 (getpoint p1"\nBearing,Dist,Line,Flip,Start,stAck,eXit
or pick-pt:"))
(cond
((eq p2 "B") (setq b (- 1 b)))
((eq p2 "D") (setq d (- 1 d)))
((eq p2 "L") (setq l (- 1 l)))
((eq p2 "F") (setq f (* f -1.0)))
((eq p2 "S") (setq p1 nil))
((eq p2 "A") (progn (setq at (- 1 at))
(if (and (= at 1) (not (and (= b 1) (= d 1))))
(progn (alert "Both Bear & Dist\nMust be on\nTurning On
NOW !\nSee CMD line")
(setq b 1
d 1
);setq
);progn
);if
));eq p2 A
((eq p2 "X") (setq p1 nil switch nil ))
((eq (type p2) 'LIST)
(progn
(grtext -1 gr)
(if (= l 1.0)
(command "LINE" p1 p2 "")
)
(setq ang1 (angle p1 p2)
ang2 (angle p2 p1)
ds (distance p1 p2)
p3 (polar p1 (angle p1 p2) (/ ds 2.0))
p1 p2
st (angtos ang1 4 4)
st (if (equal "d" (substr st 5 1))
(strcat (substr st 1 4) "%%d" (substr st 6))
(strcat (substr st 1 3) "%%d" (substr st 5)))
);setq
(if(and (> ang1 (/ pi 2.0)) (< ang1 (* pi 1.5))) (setq
ang1 ang2))
(if (= b 1)
(progn
(command
"TEXT" "J" "M" (polar p3 (+ ang1 (* f (/ pi
2.0))) th) ang1
st);cmd
);progn
);if

(if (= d 1)
(progn
(if (= at 0)
(command
"TEXT" "J" "M" (polar p3 (- ang1 (* f (/ pi
2.0))) th) ang1
(rtos ds 2 2));cmd

(command
"TEXT" "J" "M" (polar p3 (+ ang1 (* f (/ pi
2.0))) (* 2.5 th)) ang1
(rtos ds 2 2));cmd
);if
);progn
);if
);progn
);equal type p2 list
);cond
);while 2
);while 1
);end bd_main
;==========================================================
;;;Start of main program
;==========================================================
;;; The rest of the program goes here

(pushvars)
(bd_main)
(popvars)


;;; And ends here
;==========================================================
(princ)
);end c:bd













.............................................................................
.........................................................

 

I can see it just fine, 3 times