Bearing & Distance Lisp Routine

[zedd33y]

Hi all.. new to this so I hope I'm in the right area. I just got a lisp routine from here (can't remember the link) to do with bearings & distances for surveying purposes and like it BUT i was wondering if anyone can fix this to give me the option of putting the distance text below the bearing. Also i have twigged this routine to allow me to get the bearing to the nearest 05" but i don't know how to do the same for the distance to give me a tolerance of 5mm (i.e. 1.225 instead of 1.223). it lets me choose the amount of decimal places but would like the option of choosing a tolerance of 5, 10 or 1.

Bearing-Distance.lsp

[zedd33y]

Please ... can anyone help????

Edited February 10, 2015 by zedd33y

[runner214]

Here's an Oldie But Goodie.

 

Has worked for me. should work for you. Options Are what I believe you are seeking.

(defun c:laline()
  (terpri)
  ;; Annotate lines-selection set, by Carl Bassler, coded December 1998, renamed to label_line Oct 1 2001
  (princ "Annotate lines (along), distance (above) and bearings (below)")
  (setvar "cmdecho" 0)
  (command "._undo" "_BE")
  (setq dwgsnap (getvar "osmode"))
  (setvar "osmode" 0)
  (textht_0)
  
  (setq revflag 0)
  (setq revprompt (getstring "\nReverse Annotation-Brg above, dist below? (Y or N) <N>: ")) 
  (if (or (= "y" revprompt) (= "Y" revprompt)) (setq revflag 1))
  
  (setq brgflag 0)
  (setq brgprompt (getstring "\nAnnotate Brg? \(Y or N\) <N>: ")) 
  (if (or (= "y" brgprompt) (= "Y" brgprompt)) (setq brgflag 1))
  (setq disttag (getstring T "\nEnter distance units <'>: ")) 
  (if (= "" disttag) (setq disttag "'"))
  (setq txtscale (getreal (strcat "\nText Scale? <" (rtos (/ (getvar "ltscale") 10)) ">: ")))
  (if (not txtscale) (setq txtscale (/ (getvar "ltscale") 10)))
  (setq decdist (getint (strcat "\nDecimal places for distance? <2>: ")))
  (if (not decdist) (setq decdist 2))
  (if (= brgflag 1) (setq decangl (getint (strcat "\nDecimal places for bearings? <4>: "))))
  (if (not decangl) (setq decangl 4))
  ;; select lines to annotate
  ; (princ "\nSelect lines to annotate: ")
  (setq lineset nil)
  (while (not lineset) (setq lineset (ssget '((0 . "LINE")))))
  (setq numlines (sslength lineset))
  (setq itemno 0)
  ;; loop to isolate line & call dimensioning
  (repeat numlines 
    (setq entname (ssname lineset itemno))
    (setq pt1 (cdr (assoc 10 (entget entname))))
    (setq pt2 (cdr (assoc 11 (entget entname))))
    (SETQ PT1 (LIST (CAR PT1) (CADR PT1) 0.0))
    (SETQ PT2 (LIST (CAR PT2) (CADR PT2) 0.0))
    (annodim pt1 pt2)
    (setq itemno (1+ itemno))
   ) ;  repeat
  (setvar "osmode" dwgsnap)
  (textht_retn)
  (command "._undo" "_END")
  (princ)                                              
) ; annoline defun
;; *** annodim routine ***
(defun annodim (pta ptb)
 (setq brg (angle pta ptb)
       brg0 brg
       len (distance pta ptb)
       brg1 (* 100 (/ pi 180))
       brg2 (* 280 (/ pi 180)))
 (if (and (> brg brg1) (< brg brg2)) (progn
   (setq brg (- brg pi)
         pt pta
         pta ptb
         ptb pt)
 )) ; progn & if
 (setq midpoint (list (/ (+ (car pta) (car ptb)) 2) (/ (+ (cadr pta) (cadr ptb)) 2)))
 (setq annopt1 (polar midpoint (+ brg (/ pi 2)) (/ txtscale 2)))
 (setq annopt2 (polar midpoint (- brg (/ pi 2)) (* txtscale 1.5)))    
 (command "text" "c" (if (= revflag 1) annopt2 annopt1) txtscale (* brg (/ 180 pi)) (strcat (rtos len 2 decdist) disttag))
 ;; bearing anno section
 (if (= brgflag 1) (progn
   (setq brgtext (angtos brg0 4 decangl))
   (dtodeg brgtext)
   (if (= brgtext "N") (setq degstring "NORTH"))
   (if (= brgtext "S") (setq degstring "SOUTH"))
   (if (= brgtext "E") (setq degstring "EAST"))
   (if (= brgtext "W") (setq degstring "WEST"))
   (command "text" "c" (if (= revflag 1) annopt1 annopt2) txtscale (* brg (/ 180 pi)) degstring)
 )) ; progn & if
) ; annodim
;; routine to convert d to %%d
(defun dtodeg (survtxt)
 (setq degstring "")
 (setq lenstring (strlen survtxt))
 (setq charcount 1)
 (repeat lenstring
   (setq charn (substr survtxt charcount 1))
   (if (and (> charcount 1) (<= charcount (- lenstring 1))) (progn  ; ensures 2-digit min & sec
     (setq char1p (substr survtxt (- charcount 1) 1))
     (setq char1m (substr survtxt (+ charcount 1) 1))
     (if (and (= char1p " ") (= char1m "d")) (setq charn (strcat "0" charn)))
     (if (and (= char1p "d") (= char1m "'")) (setq charn (strcat "0" charn)))
     (if (and (= char1p "'") (= char1m "\"")) (setq charn (strcat "0" charn)))
   )) ; progn & if
   (if (= charn "d") (setq charn "%%d"))
   (if (= charn " ") (setq charn ""))
   (setq degstring (strcat degstring charn))
   (setq charcount (1+ charcount))
 ) ; repeat
 (princ)
) ; dtodeg
;; function to set textht to zero if not
(defun textht_0 ()
 (setq dwg_style (getvar "textstyle"))
 (setq styledata (tblsearch "style" dwg_style))
 (setq dwg_ht (cdr (assoc 40 styledata)))
 (if (/= dwg_ht 0) (command "style" "" "" "0.0" "" "" "" "" ""))
) ; defun
;; function to set textht back to original
(defun textht_retn ()
 (if (/= dwg_ht 0) (command "style" "" "" dwg_ht "" "" "" "" ""))
 (princ)
) ; defun
(princ "\nStart with LALINE ")

[zedd33y]

Hi runner214.... thanks for the attempt but i have seen this one b4 and the problem is which i forgot to mention is i have have my units set to clockwise & direction north 270d (ie to read zero up the page & 90d east)... also i prefer no N,S,E or W in the bearing and still i cant get the 5 sec tolerance

[Preston Miles]

RUNNER 214 This lisp program work well except the fact that the length of the line is 12 times the actual length. I there a fix that I can do to correct this??

[runner214]

Works fine here. I use decimal foot.

[zedd33y]

Hey Runner214 is there any answer to my original question... any chance of a fix for the lisp i posted

[Guest]

 

Hi i am using the following settigs (look the photos).

Can any one update the code to grads and meters ,and support lines and polylines

 

(defun c:laline()
  (terpri)
  ;; Annotate lines-selection set, by Carl Bassler, coded December 1998, renamed to label_line Oct 1 2001
  (princ "Annotate lines (along), distance (above) and bearings (below)")
  (setvar "cmdecho" 0)
  (command "._undo" "_BE")
  (setq dwgsnap (getvar "osmode"))
  (setvar "osmode" 0)
  (textht_0)
  
  (setq revflag 0)
  (setq revprompt (getstring "\nReverse Annotation-Brg above, dist below? (Y or N) <N>: ")) 
  (if (or (= "y" revprompt) (= "Y" revprompt)) (setq revflag 1))
  
  (setq brgflag 0)
  (setq brgprompt (getstring "\nAnnotate Brg? \(Y or N\) <N>: ")) 
  (if (or (= "y" brgprompt) (= "Y" brgprompt)) (setq brgflag 1))
  (setq disttag (getstring T "\nEnter distance units <'>: ")) 
  (if (= "" disttag) (setq disttag "'"))
  (setq txtscale (getreal (strcat "\nText Scale? <" (rtos (/ (getvar "ltscale") 10)) ">: ")))
  (if (not txtscale) (setq txtscale (/ (getvar "ltscale") 10)))
  (setq decdist (getint (strcat "\nDecimal places for distance? <2>: ")))
  (if (not decdist) (setq decdist 2))
  (if (= brgflag 1) (setq decangl (getint (strcat "\nDecimal places for bearings? <4>: "))))
  (if (not decangl) (setq decangl 4))
  ;; select lines to annotate
  ; (princ "\nSelect lines to annotate: ")
  (setq lineset nil)
  (while (not lineset) (setq lineset (ssget '((0 . "LINE")))))
  (setq numlines (sslength lineset))
  (setq itemno 0)
  ;; loop to isolate line & call dimensioning
  (repeat numlines 
    (setq entname (ssname lineset itemno))
    (setq pt1 (cdr (assoc 10 (entget entname))))
    (setq pt2 (cdr (assoc 11 (entget entname))))
    (SETQ PT1 (LIST (CAR PT1) (CADR PT1) 0.0))
    (SETQ PT2 (LIST (CAR PT2) (CADR PT2) 0.0))
    (annodim pt1 pt2)
    (setq itemno (1+ itemno))
   ) ;  repeat
  (setvar "osmode" dwgsnap)
  (textht_retn)
  (command "._undo" "_END")
  (princ)                                              
) ; annoline defun
;; *** annodim routine ***
(defun annodim (pta ptb)
 (setq brg (angle pta ptb)
       brg0 brg
       len (distance pta ptb)
       brg1 (* 100 (/ pi 180))
       brg2 (* 280 (/ pi 180)))
 (if (and (> brg brg1) (< brg brg2)) (progn
   (setq brg (- brg pi)
         pt pta
         pta ptb
         ptb pt)
 )) ; progn & if
 (setq midpoint (list (/ (+ (car pta) (car ptb)) 2) (/ (+ (cadr pta) (cadr ptb)) 2)))
 (setq annopt1 (polar midpoint (+ brg (/ pi 2)) (/ txtscale 2)))
 (setq annopt2 (polar midpoint (- brg (/ pi 2)) (* txtscale 1.5)))    
 (command "text" "c" (if (= revflag 1) annopt2 annopt1) txtscale (* brg (/ 180 pi)) (strcat (rtos len 2 decdist) disttag))
 ;; bearing anno section
 (if (= brgflag 1) (progn
   (setq brgtext (angtos brg0 4 decangl))
   (dtodeg brgtext)
   (if (= brgtext "N") (setq degstring "NORTH"))
   (if (= brgtext "S") (setq degstring "SOUTH"))
   (if (= brgtext "E") (setq degstring "EAST"))
   (if (= brgtext "W") (setq degstring "WEST"))
   (command "text" "c" (if (= revflag 1) annopt1 annopt2) txtscale (* brg (/ 180 pi)) degstring)
 )) ; progn & if
) ; annodim
;; routine to convert d to %%d
(defun dtodeg (survtxt)
 (setq degstring "")
 (setq lenstring (strlen survtxt))
 (setq charcount 1)
 (repeat lenstring
   (setq charn (substr survtxt charcount 1))
   (if (and (> charcount 1) (<= charcount (- lenstring 1))) (progn  ; ensures 2-digit min & sec
     (setq char1p (substr survtxt (- charcount 1) 1))
     (setq char1m (substr survtxt (+ charcount 1) 1))
     (if (and (= char1p " ") (= char1m "d")) (setq charn (strcat "0" charn)))
     (if (and (= char1p "d") (= char1m "'")) (setq charn (strcat "0" charn)))
     (if (and (= char1p "'") (= char1m "\"")) (setq charn (strcat "0" charn)))
   )) ; progn & if
   (if (= charn "d") (setq charn "%%d"))
   (if (= charn " ") (setq charn ""))
   (setq degstring (strcat degstring charn))
   (setq charcount (1+ charcount))
 ) ; repeat
 (princ)
) ; dtodeg
;; function to set textht to zero if not
(defun textht_0 ()
 (setq dwg_style (getvar "textstyle"))
 (setq styledata (tblsearch "style" dwg_style))
 (setq dwg_ht (cdr (assoc 40 styledata)))
 (if (/= dwg_ht 0) (command "style" "" "" "0.0" "" "" "" "" ""))
) ; defun
;; function to set textht back to original
(defun textht_retn ()
 (if (/= dwg_ht 0) (command "style" "" "" dwg_ht "" "" "" "" ""))
 (princ)
) ; defun
(princ "\nStart with LALINE ")

 

thanks