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

Robert

Robert

Robert wrote:

I wrote one a few years ago. Probably you could download something better from some "official" site. Mine is pretty simple.

If you find nothing that suites, send me an email.

melkor@[superfluoustext]socket.net

you will need to remove all superflous text though.

I wrote one a few years ago. Probably you could download something better from some "official" site. Mine is pretty simple.

If you find nothing that suites, send me an email.

melkor@[superfluoustext]socket.net

you will need to remove all superflous text though.

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

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

;=========================================================; 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

;=========================================================; Restore System Variables ;========================================================= (Defun popvars ( ) (ForEach pair sysvars (Setvar (CAR pair) (CDR pair)) ) (Setq

(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 (

(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

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

wrote:

I can see it just fine, 3 times :D

I can see it just fine, 3 times :D

### Offset Text lisp routine

- - next thread in AutoCAD discussions

### video cards

- - previous thread in AutoCAD discussions

### Help to get started on project (Case trimmer)

- - newest thread in AutoCAD discussions

### Sell Your AutoCad Drawings

- - last updated thread in AutoCAD discussions

### Off to the Shop

- - the site's newest thread. Posted in ⏣ General Metalworking

### Schuko-Doppelstecker: Multi-Steckdosen /-Verteiler

- - the site's last updated thread. Posted in ⏚ Electrical Engineering (German)