Please help me i need lisp

[kkr028]

Please help me i need lisp for this calculations

TP1 length = Curve polyline length up to every TP-1 and place text as " TP-1@ ??.??? KM' "
TP2 length = Curve polyline length up to every TP-2 and place text as " TP-2@ ??.??? KM' "
APEX length = (Curve polyline length up to every TP-1 + tangent length and place text as " APEX-? AT ??.??? KM "
FORWARD BARRING = place text as " FB : ???° ??' ?? "

[Sea-Haven]

Did you google chainage.lsp lots of variations may find one that matches your requirements.

[john.uhden]

Civil 3D

[Sea-Haven]

Answer over at Cadtutor.

[CADaSchtroumpf · Accepted solution]

I hope a sucess with this...

(vl-load-com)
(defun make_mtext (ent prm ang flag / deriv dir nw_obj pt al alf)
  (setq
    deriv (vlax-curve-getFirstDeriv ent prm)
    dir (if flag (atan (cadr deriv) (car deriv)) (+ (atan (cadr deriv) (car deriv)) (* 0.5 pi)))
  )
  (setq
    nw_obj
    (vla-addMtext Space
      (vlax-3d-point
        (if flag
          (setq pt (polar (vlax-curve-GetPointAtParam ent (+ 0.5 prm)) (+ dir (* pi 0.5)) (getvar "TEXTSIZE")))
          (if (eq (type prm) 'INT)
            (setq pt (polar (vlax-curve-GetPointAtParam ent prm) dir (getvar "TEXTSIZE")))
            (setq pt (polar pt_vtx dir (getvar "TEXTSIZE")))
          )
        )
      )
      0.0
      (if flag
        (strcat "{\\C1;FB : " (vl-string-subst "%%d" "d" (angtos ang)) "}")
        (if (eq (type prm) 'INT)
          (strcat "{\\C5;TP-" (itoa nb) " " (rtos (* 0.001 ang) 2 3) " KM}")
          (strcat "{\\C1;APEX-" (itoa nbs) " AT " (rtos (* 0.001 ang) 2 3) " KM}")
        )
      )
    )
  )
  (if (or (> dir (* pi 0.5)) (< dir (- (* pi 0.5)))) (setq dir (+ dir pi) al 6 alf 2) (setq al 4 alf 8))
  (mapcar
    '(lambda (pr val)
      (vlax-put nw_obj pr val)
    )
    (list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation)
    (list (if flag alf al) (getvar "TEXTSIZE") 5 pt "DIM-CHAINAGE" (getvar "CLAYER") dir)
  )
)
(defun c:APEX ( / js l_var htx AcDoc Space nw_style n ename obj pr nbs cum_len dist_start dist_end pt_start pt_end alpha seg_len seg_bulge nb rad ang_vtx pt_cen pt_vtx ang_vtx x)
  (princ "\nSelect polylines.")
  (while
    (null
      (setq js
        (ssget
          '(
            (0 . "*POLYLINE")
            (-4 . "<NOT")
              (-4 . "&") (70 . 112)
            (-4 . "NOT>")
          )
        )
      )
    )
    (princ "\nSelect is empty, or isn't POLYLINE!")
  )
  (initget 6)
  (setq htx (getdist (getvar "VIEWCTR") (strcat "\nSpecify height text <" (rtos (getvar "TEXTSIZE")) ">: ")))
  (if htx (setvar "TEXTSIZE" htx))
  (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 "LAYER" "CHAINAGE"))
      (vlax-put (vla-add (vla-get-layers AcDoc) "CHAINAGE") 'color 7)
    )
  )
  (cond
    ((null (tblsearch "STYLE" "DIM-CHAINAGE"))
      (setq nw_style (vla-add (vla-get-textstyles AcDoc) "DIM-CHAINAGE"))
      (mapcar
        '(lambda (pr val)
          (vlax-put nw_style pr val)
        )
        (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
        (list (strcat (getenv "windir") "\\fonts\\arial.ttf") 0.0 0.0 1.0 0.0)
      )
    )
  )
  (setq l_var (mapcar 'getvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS" "CLAYER")))
  (mapcar 'setvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS" "CLAYER") (list 0 0 0 1 3 2 2 "CHAINAGE"))
  (repeat (setq n (sslength js))
    (setq
      ename (ssname js (setq n (1- n)))
      obj (vlax-ename->vla-object ename)
      pr -1
      nbs 0
      cum_len 0.0
    )
    (repeat (fix (vlax-curve-getEndParam ename))
      (setq
        dist_start (vlax-curve-GetDistAtParam ename (setq pr (1+ pr)))
        dist_end (vlax-curve-GetDistAtParam ename (1+ pr))
        pt_start (vlax-curve-GetPointAtParam ename pr)
        pt_end (vlax-curve-GetPointAtParam ename (1+ pr))
        alpha (angle pt_start pt_end)
        seg_len (- dist_end dist_start)
        seg_bulge (vla-GetBulge obj pr)
        nb 0
      )
      (if (not (zerop seg_bulge))
        (progn
          (setq
            rad (/ seg_len (* 4.0 (atan seg_bulge)))
            ang_vtx (+ (angle pt_start pt_end) (- (* pi 0.5) (* 2.0 (atan seg_bulge))))
            pt_cen (polar pt_start ang_vtx rad)
            pt_vtx (polar pt_start (- ang_vtx (* pi 0.5)) (* rad (/ (sin (* 2.0 (atan seg_bulge))) (cos (* 2.0 (atan seg_bulge))))))
            ang_vtx (if (< (* 2.0 (atan seg_bulge)) 0) (- pi (* 2.0 (atan seg_bulge))) (* 2.0 (atan seg_bulge)))
            nbs (1+ nbs)
            nb (1+ nb)
            x (angle pt_cen pt_vtx)
          )
          (make_mtext ename pr cum_len nil)
          (setq cum_len (+ cum_len (distance pt_start pt_vtx)))
          (entmake (list '(0 . "LINE") '(62 . 1) (cons 10 pt_start) (cons 11 pt_vtx)))
          (make_mtext ename (+ 0.5 pr) cum_len nil)
          (entmake (list '(0 . "LINE") '(62 . 1) (cons 10 pt_vtx) (cons 11 pt_end)))
          (setq cum_len dist_end nb (1+ nb))
          (make_mtext ename (1+ pr) cum_len nil)
        )
        (progn
          (make_mtext ename pr alpha T)
          (setq cum_len (+ cum_len seg_len))
        )
      )
      
    )
  )
  (mapcar 'setvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS" "CLAYER") l_var)
  (prin1)
)

[kkr028]

Hi sir,

Thank you very much for lisp.

Almost 99% my problem solved sir.

I want little change sir.

Please can you change it sir.

We need

FB= Just Angle from "North to Alignment (towards Direction)".

 

[CADaSchtroumpf · Accepted solution]

For make this, replace value applied by setvar at ANGBASE and ANGDIR

In the code change the line

  ;replace
  ;(mapcar 'setvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS" "CLAYER") (list 0 0 0 1 3 2 2 "CHAINAGE"))
  ;by
  (mapcar 'setvar '("DIMZIN" "ANGDIR" "ANGBASE" "AUNITS" "AUPREC" "LUPREC" "LUNITS" "CLAYER") (list 0 1 (* pi 0.5) 1 3 2 2 "CHAINAGE"))

[kkr028]

thank you sir,

100 % working.