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 yesterday at 03:35 AM by oliver

[mhupp]

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

Edited 15 hours 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)
)

 

[oliver]

11 hours ago, Tsuky said:

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

 

Thank you the code is perfectly fine and work..but some a little adjustment 

here some photos and hope the osnap works this time..

Edited 4 hours ago by oliver

[mhupp]

Nice Tsuky tho i use this when setting multiple variables. less likely to get the order mixed up if their is only one list.

  (setq vars '(DIMZIN ANGDIR ANGBASE AUNITS AUPREC LUPREC LUNITS TEXTSIZE)  ;list of variables
        vals (mapcar 'getvar vars)      ;store old values
  )
  (mapcar 'setvar vars (list 0 1 (* pi 0.5) 4 3 2 2))  ;set new values
  ...
  (mapcar 'setvar vars vals)  ;restore old values
  

 

@oliver i think you want North to be 0 instead of East? so you have to subtract that from the angle in angtos. updating  this line should give you what your looking for.

val_txt (vl-string-subst "%%d" "d" (strcat (angtos (- (/ pi 2) alpha) 4 3) "\\P " (rtos len_l) " m"))