Need a routine lisp for bearing & azimuth in realtime.

[oliver]

Good day once again..and Happy new year..

tired of doing manual and change the units everytime check the direction..

here is the photo.

Thanks in advanced.

Edited 12 hours ago by oliver

[mhupp]

going to use grread and mouse pointer. maybe edit Demo2?

Edited 1 hour ago by mhupp
Demo2 url

[Tsuky]

A start with this?

(vl-load-com)
(defun c:label_bearing ( / l_var AcDoc Space nw_style nw_obj dxf_text pt1 pt2 dxf_line key pt alpha len_l m_pt val_txt)
  (setq l_var (mapcar 'getvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS" "TEXTSIZE")))
  (mapcar 'setvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS") (list 0 1 (* pi 0.5) 4 3 2 2))
  (setvar "TEXTSIZE" (* (getvar "VIEWSIZE") 0.015))
  (setq
    AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
    Space
    (if (= 1 (getvar "CVPORT"))
      (vla-get-PaperSpace AcDoc)
      (vla-get-ModelSpace AcDoc)
    )
  )
  (vla-startundomark AcDoc)
  (cond
    ((null (tblsearch "STYLE" "BEARING"))
      (setq nw_style (vla-add (vla-get-textstyles AcDoc) "BEARING"))
      (mapcar
        '(lambda (pr val)
          (vlax-put nw_style pr val)
        )
        (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
        (list "romand.shx" 0.0 0.0 1.0 0.0)
      )
    )
  )
  (setq
    nw_obj
    (vla-addMtext Space
      (vlax-3d-point '(0.0 0.0 0.0))
      0.0
      ""
    )
    dxf_text (entget (entlast))
  )
  (initget 1)
  (setq
    pt1 (getpoint "\nPick base point: ")
    pt2 pt1
  )
  (entmake (list (cons 0 "LINE") (cons 10 pt1) (cons 11 pt2)))
  (setq dxf_line (entget (entlast)))
  (while (equal pt2 pt1)
    (setq pt2
      ((lambda ( / key pt alpha len_l m_pt)
        (princ "\nPick other point: ")
        (while (and (setq key (grread T 4 0)) (/= (car key) 3))
          (cond
            ((eq (car key) 5)
              (redraw)
              (setq
                pt (cadr key)
                alpha (angle pt1 pt)
                len_l (distance pt1 pt)
                m_pt (mapcar '* (mapcar '+ pt1 pt) '(0.5 0.5 0.5))
                val_txt (vl-string-subst "%%d" "d" (strcat (angtos alpha) "\\P " (rtos len_l) " m"))
                dxf_line
                (entmod
                  (subst
                    (cons 11 pt)
                    (assoc 11 dxf_line)
                    dxf_line
                  )
                )
              )
              (if (and (> alpha (* pi 0.5)) (<= alpha (* pi 1.5)))
                (setq alpha (+ alpha pi))
              )
              (mapcar
                '(lambda (pr val)
                  (vlax-put nw_obj pr val)
                )
                (list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation 'TextString 'Color)
                (list 5 (getvar "TEXTSIZE") 5 m_pt "BEARING" (getvar "CLAYER") alpha val_txt 2)
              )
              (entmod
                (subst
                  (cons 50 alpha)
                  (assoc 50 dxf_text)
                  (subst (cons 10 (polar m_pt (+ alpha (* pi 0.5)) (getvar "TEXTSIZE"))) (assoc 10 dxf_text) dxf_txt)
                )
              )
            )
          )
        )
        (cadr key)
      ))
    )
  )
  (vla-endundomark AcDoc)
  (mapcar 'setvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS" "TEXTSIZE") l_var)
  (prin1)
)