Help to Modify Existing Line Annotation LISP

[KraZeyMike]

I have this Lisp (Edited by me) that works really well.

However I would really appreciated being able to incorporate three things beyond my skill level:

- Arc Lengths with the prefix "A"

- Mtext output rather than standard Text (I tried simply changing TEXT to MTEXT and a few other tweaks without success)

- Remove trailing 00" (I already have a work around for this but it would be great to have incorporated into the existing lisp)

 

Any help is greatly appreciated.

 

Code Here:

Quote

;;Bearing and Distance 4 © 2020 Ronald Harman (dlanorh)
;;Released under MIT Licence https://opensource.org/licenses/MIT

(vl-load-com)

(defun rh:R2D (r) (* 180.0 (/ r pi)))

(defun gc:round (num prec) (if (zerop (setq prec (abs prec))) num (* prec (fix ((if (minusp num) - +) (/ num prec) 0.5)))))

(defun rh:midpoint ( pt1 pt2 / pt3 ) (setq pt3 (mapcar '(lambda (x y) (/ (+ x y) 2)) pt1 pt2)))

(defun rh:2azimuth ( a_brg / d a_azi)
  (setq d (fix a_brg))
  (cond ((and (>= d 0) (< d 90)) (setq a_azi (- 90 a_brg)))
        ((and (>= d 90) (< d 180)) (setq a_azi (- 360 (- a_brg 90))))
        ((and (>= d 180) (< d 270)) (setq a_azi (- 270 (- a_brg 180))))
        ((and (>= d 270) (< d 360)) (setq a_azi (- 90 (- a_brg 360))))
  )
  (setq d a_azi)
);_end_defun

; converts radian brg to dms text
(defun rh:2dms ( r_brg rnd / d_brg d m s b_str)
  (setq d_brg (rh:2azimuth (rh:R2D r_brg))
        d (fix d_brg)
        m (fix (* (rem d_brg 1.0) 60))
        s (gc:round (* (rem (* (rem d_brg 1.0) 60) 1.0) 60) rnd)
  );_end_setq
  (if (>= s 59.5) (setq m (1+ m) s 0.0))
  (if (= m 60) (setq d (1+ d) m 0))
  (if (>= d 360) (setq d (- d 360)))
  (setq s (rtos s 2 0) m (itoa m) d (itoa d))
  (if (< (atoi s) 10) (setq s (strcat "0" s)))
  (if (< (atoi m) 10) (setq m (strcat "0" m)))
  ;(while (< (strlen d) 3) (setq d (strcat "0" d)))
  (setq b_str (strcat d "\260" m "'" s "\""))
);_end_defun

(defun rh:em_txt ( pt txt lyr ang tht d72 d73)
  (entmakex (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText")
                 (cons 8 lyr) (cons 50 ang) (cons 7 (getvar 'textstyle)) (cons 1 txt)
                 (cons 10 pt) (cons 40 tht) (cons 72 d72) (cons 11 pt) (cons 73  d73)
            )
  )
);end_defun

;;BEGIN MAIN ROUTINE
(defun C:BAD ( / *error* sv_lst sv_vals tht b_lyr_lst d_lyr_lst lyr_idx d_rnd a_rnd lans pik lyr_e l_lst lt dv txt b_lyr d_lyr l_obj l_ang a_txt l_txt m_pt i_ang d_pt)
(setvar "DIMZIN" 8)
  (defun *error* ( msg )
    (mapcar 'setvar sv_lst sv_vals)
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
    (princ)
  );_end_*error*_defun

  (setq sv_lst (list 'cmdecho 'osmode 'dynmode 'dynprompt 'textsize)
        sv_vals (mapcar 'getvar sv_lst)
  );end_setq

  (mapcar 'setvar sv_lst '(0 0 3 1))

;; User Variables
  (setq b_lyr_lst (list "Text_3.5 Bearing" "Text_2.8 Bearing Connection") ;; Bearing Layer list (first item is always default)
        d_lyr_lst (list "Text_3.5 Distance" "Text_2.8 Distance Connection") ;; Distance Layer list (first item is always default)
        lyr_idx 0                               ;; Index for the above lists PLEASE DON'T CHANGE
        d_rnd 3                                 ;; Rounding for distance (Integer, number of decimal places)
        a_rnd 5.0                              ;; Rounding for angles (Real Seconds of Arc)
  );end_setq

  (initget "Boundaries Connections")
  (setq lans (cond ( (getkword (strcat "\nUse Boundaries (" (nth lyr_idx b_lyr_lst)" & " (nth lyr_idx d_lyr_lst) ") or Connections Layers : ? [Boundaries/Connections] <Boundaries>"))) ("Boundaries")))
  (if (= lans "Connections") (setq lyr_idx 1 pik "Boundaries") (setq pik "Connections"))

  (setq b_lyr (nth lyr_idx b_lyr_lst) d_lyr (nth lyr_idx d_lyr_lst))

  (foreach lyr (list b_lyr d_lyr) (if (not (tblsearch "layer" lyr)) (setq lyr_e T l_lst (cons lyr l_lst))))

  (cond (lyr_e
          (if (= (length l_lst) 2)  (setq lt "layers" dv " , ") (setq lt "layer" dv ""))
          (setq txt (strcat "MISSING LAYERS\n\nOption " lans " " lt " : "))
          (mapcar '(lambda (x) (setq txt (strcat txt x dv))) l_lst)
          (setq txt (vl-string-right-trim " ," txt))
          (alert (strcat txt "\n\nPlease rectify missing " lt " or re-run\nand select " pik " option"))
        )
  );end_cond (missing layers)

  (initget 6)
  (setq tht (cond ( (getreal (strcat "\nEnter Text Size : <" (rtos (getvar 'textsize) 2 3) ">"))) ( (getvar 'textsize))))

  (cond ( (not lyr_e)
          (princ "\nSelect Lines : ")
          (setq ss (ssget '((0 . "LINE"))))
          (cond (ss
                  (repeat (setq cnt (sslength ss))
                    (setq l_obj (vlax-ename->vla-object (setq ent (ssname ss (setq cnt (1- cnt)))))
                          elst (entget ent)
                          l_ang (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ent 0))
                          a_txt (rh:2dms l_ang a_rnd)
                          l_txt (rtos (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 2 d_rnd)
                          m_pt (rh:midpoint (vlax-get l_obj 'startpoint) (vlax-get l_obj 'endpoint))
                    );_end_setq
                    (setq i_ang l_ang)
                    (if (and (>= l_ang (* pi 0.5)) (< l_ang (* pi 1.5)))
                      (setq i_ang (- l_ang pi) d_pt (polar m_pt (- i_ang (* pi 0.5)) (* tht 0.3)))
                      (setq d_pt (polar m_pt (- i_ang (* pi 0.5)) (* tht 0.3)))
                    );end_if
                    (rh:em_txt m_pt a_txt b_lyr i_ang tht 1 1)
                    (rh:em_txt d_pt l_txt d_lyr i_ang tht 1 3)
                  );end_repeat
                )
          );end_cond
        )
  );end_cond
  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);_end_defun
(princ)

 

Edited 4 hours ago by KraZeyMike
Emoticon Removal from Code

[BIGAL]

I would maybe start again, if you look at this https://www.lee-mac.com/polyinfo.html it will find arcs etc in plines  So if you want to label Lines, Arcs, Circles and Plines, you may need different code that looks at each entiity and correctly labels.

 

I had a quick google and found a few programs I know that Kent Cooper has something similar to Lee's, but labels each segment. Search also "forums/autodesk".

[mhupp]

Sample drawing with correct layers and what your looking for?

 

For mtext update the entmake with the following. 71 is the text justification defaulting to mid center. use \n for next line.

 

(defun rh:em_mtxt (pt txt lyr ang hgt)
  (entmakex (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText")
                   (cons 8 lyr) (cons 50 ang) (cons 7 (getvar 'TEXTSTYLE)) (cons 1 txt)
                   (cons 10 pt) (cons 40 hgt) (cons 50 ang) '(71 . 5)
            )
  )
)

(rh:em_mtxt '(0 0 0) "hello\nthere" "0" 0 0.5)

 

rh:2azimuth can be replace with (angtos l_ang 1 5)