Jump to content

Request for Chainage Lisp Modify

Bittuds1996

By Bittuds1996
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Bittuds1996 Apprentice

Bittuds1996

Posted
Posted

Hi Experts,

I downloaded the Chainage Lisp created by hak_vz. In their code, chainage is plotted with an interval. However, I would like to obtain the chainage when I click on an intersection point or anywhere on the selected polyline. Could you please help me with this?

 

I have also attached the Lisp file for reference.

 

chainage_hak_vz.lsp

Link to comment
Share on other sites
Steven P Grand Master

Steven P

Posted
Posted

I have something that might work, it works the other way around - you tell it distances and it will put the chainage markers there... just need to add a measure to it.. will think about it tomiorrow

Link to comment
Share on other sites
Steven P Grand Master

Steven P

Posted
Posted

I am just going to put this here as a starter, LSChainage using Lee Macs Chainage LISP as a base. This modification lets you select numbers on a drawing, enter then select the line, plotting a block at the chainage.

 

Needs a little modification to take away the number selection and calculate the distance along the line - that's the part I will look at later. This part was just copied and pasted from my stuff

 

 

  

;;https://www.cadtutor.net/forum/topic/1264-drawing-points-along-polyline/
(defun C:LSChainage ( / MyPt ppt pent ang cumm_dist dis dist_list leng obj pt reversed)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Set Attribute Value  -  Lee Mac
;; Sets the value of the first attribute with the given tag found within the block, if present.
;; blk - [ent] Block (Insert) Entity Name
;; tag - [str] Attribute TagString
;; val - [str] Attribute Value
;; Returns: [str] Attribute value if successful, else nil.
  (defun LM:setattributevalue ( blk tag val / enx )
      (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
          (if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
              (if (entmod (subst (cons 1 val) (assoc 1 (reverse enx)) enx))
                  (progn
                      (entupd blk)
                      val
                  )
              )
              (LM:setattributevalue blk tag val)
          )
      )
  )
;;Chainage, make a small mark every 1/2 distance and add distance and big mark every distance
  (defun make_blk_measure ( / )
    (if (not (tblsearch "STYLE" "$BLK_MEAS"))
      (entmake '((0 . "STYLE")
      (5 . "40")
      (100 . "AcDbSymbolTableRecord")
      (100 . "AcDbTextStyleTableRecord")
      (2 . "$BLK_MEAS")
      (70 . 0)
      (40 . 0.0)
      (41 . 0.7)
      (50 . 0.0)
      (71 . 0)
      (42 . 0.1)
      (3 . "ARIAL.TTF")
      (4 . "")
     )
      )
    )
    (if (not (tblsearch "BLOCK" "BLK_MEASURE_CURVE"))
      (progn
   (entmake
    '((0 . "BLOCK") (8 . "0") (2 . "BLK_MEASURE_CURVE") (70 . 2) (4 . "") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2) (10 0.0 0.0 0.0))
  )
  (entmake
    (append
      '((0 . "LINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2) (100 . "AcDbLine"))
      (list (list 10 0.0 (- (getvar "TEXTSIZE")) 0.0))
      (list (list 11 0.0 (getvar "TEXTSIZE") 0.0))
      '((210 0.0 0.0 1.0))
    )
   )
   (entmake
    '(
  (0 . "ATTDEF")
  (100 . "AcDbEntity")
  (67 . 0)
  (410 . "Model")
  (8 . "0")
  (62 . 0)
  (6 . "ByBlock")
  (370 . -2)
  (100 . "AcDbText")
  (10 0.0 0.0 0.0)
  (40 . 1.0)
  (1 . "0.0")
  (50 . 1.570796326794896)
  (41 . 0.7)
  (51 . 0.0)
  (7 . "$BLK_MEAS")
  (71 . 8)
  (72 . 1)
  (11 1.0 0.0 0.0)
  (210 0.0 0.0 1.0)
  (100 . "AcDbAttributeDefinition")
  (3 . "measure")
  (2 . "VALUE_MEASURE")
  (70 . 0)
  (73 . 0)
  (74 . 1)
    )
  )
  (entmake '((0 . "ENDBLK") (8 . "0") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2)))
      )
    )

    (if (not (tblsearch "BLOCK" "BLK_TICK_CURVE"))
      (progn
   (entmake
    '((0 . "BLOCK") (8 . "0") (2 . "BLK_TICK_CURVE") (70 . 2) (4 . "") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2) (10 0.0 0.0 0.0))
  )
  (entmake
    (append
      '((0 . "LINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2) (100 . "AcDbLine"))
      (list (list 10 0.0 (* 0.5 (- (getvar "TEXTSIZE"))) 0.0))
      (list (list 11 0.0 (* 0.5 (getvar "TEXTSIZE")) 0.0))
      '((210 0.0 0.0 1.0))
    )
  )
  (entmake '((0 . "ENDBLK") (8 . "0") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2)))
      )
    )
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/end-selection-in-loop-with-enter-button/td-p/8815294
  (defun LSGrabTexts ( / distlist ent)
    (setq distlist nil)
    (setvar 'errno 0)
    (while ; lop selecting texts
      (progn (setvar 'errno 0) (setq ent (car (entsel "\nSelect Text: ")))
        (cond
          (   (= 7 (getvar 'errno)) ;cond a
            (princ "\nMissed, try again.")
          ) ;end cond a
          (   (= 'ename (type ent)) ;cond b
            (princ (setq dist (cdr (assoc 1 (entget ent)))) )
            (setq distlist (append distlist (list (atof dist))))
          ) ;end cond b
        )
      )
    )
    (princ "\nDistances: ")(princ distlist)
    distlist
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (setq dist_list (LSGrabTexts)) ; get absolute distances
  (setq dist_list_orig dist_list)
  (setq cumm_dist (apply 'max dist_list))
  (setq dis 0.0)
  (setq pent (car (entsel "\n >> Select profile >>")))
  (setq ppta (assoc 10 (entget pent))) ; start of route line
  (setq pptb (assoc 10 (reverse (entget pent)) )) ; end of route line
  (setq MyPt (getpoint "\nSelect Start Point"))
  (setq obj (vlax-ename->vla-object pent))
  (setq leng (vlax-curve-getdistatpoint obj (vlax-curve-getendpoint obj)))

  (if (or ;; Selected MyPt at ends of route line
      (= (vlax-curve-getdistatpoint obj MyPt) 0)
      (= (vlax-curve-getdistatpoint obj MyPt) leng)
    )
    (progn
    ) ; end progn
    (progn
      (setq MyEndPt (getpoint "\nSelect a Point in the Direction"))
      (setq lenga (vlax-curve-getdistatpoint obj MyPt))
      (setq lengb (vlax-curve-getdistatpoint obj MyEndPt))
      (if (< lenga lengb)
        (progn
          (princ "\nA-B Calc Start Point")
          (setq newlist (list))
          (setq acount 0)
          (while (< acount (length dist_list))
            (setq newval (+ lenga (nth acount dist_list)))
            (if (< newval 0)(setq newval 0))
            (setq newlist (append newlist (list newval)))
            (setq acount (+ acount 1))
          )
          (setq dist_list newlist)
          (setq MyPt (list (cadr ppta) (caddr ppta) 0) )
        ) ; end progn
        (progn
          (princ "\nB-A Calc Start Point")
          (setq newlist (list))
          (setq acount 0)
          (while (< acount (length dist_list))
            (setq newval (+ (- leng lenga) (nth acount dist_list)))
            (if (< newval 0)(setq newval 0))
            (setq newlist (append newlist (list newval)))
            (setq acount (+ acount 1))
          )
          (setq dist_list newlist)
          (setq MyPt (list (cadr pptb) (caddr pptb) 0) )
        ) ; end progn
      ) ; end if
    ) ; end progn
  ) ; end if


  (if (= (vlax-curve-getdistatpoint obj MyPt) 0)
    ()
    (progn
      (princ "\nReverse")
      (setq newlist (list))
      (setq acount 0)
      (while (< acount (length dist_list))
        (setq newval (- leng (nth acount dist_list)))
        (if (< newval 0)(setq newval 0))
        (setq newlist (append newlist (list newval)))
        (setq acount (+ acount 1))
      )
      (princ newlist)
      (setq dist_list newlist)
    )
  ) ; end if

  (setq acount 0)
  (while (< acount (length dist_list))
    (setq dis (nth acount dist_list))
    (if (> (nth acount dist_list) leng)(setq dis leng)) ;; fudge if SOP greater than route length??
    (setq pt (vlax-curve-getpointatdist obj dis))
;;insert block 'tick'
    (make_blk_measure)
    (setq ang (angle '(0 0 0) (vlax-curve-getfirstderiv obj (vlax-curve-getparamatpoint obj pt))))
    (vlax-invoke (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) 'InsertBlock pt "BLK_MEASURE_CURVE" 1 1 1 ang)
    (setq MyLastBlock (entlast))

    (LM:setattributevalue MyLastBlock "VALUE_MEASURE" (strcat (rtos acount) ": " (rtos (nth acount dist_list_orig))) )

;;or draw point:
;;      (vlax-invoke (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) 'AddPoint pt) (setq dist_list (cdr dist_list))
    (setq acount (+ acount 1))
  ) ;end while

  (princ)
)

 

  • Like 1
Link to comment
Share on other sites
Steven P Grand Master

Steven P

Posted
Posted
2 hours ago, Bittuds1996 said:

This code adds the ability to pick a text and then plot chainage. However, I only want the code to pick the point's chainage.

 

 

 

 

.. I know.... if you read the words "Needs a little modification to take away the number selection and calculate the distance along the line - that's the part I will look at later" it ex[plains that....

Link to comment
Share on other sites
Steven P Grand Master

Steven P

Posted
Posted (edited)

Just putting this here, will edit this post later (dinner time I, want to save this somewhere before I turn the computer off).

 

So this will put a block at each selected point, command is chainage. Hope the prompts work OK - select a line, select an end point, loop through selecting points, click OK, should be OK.

 

I need to add in  a thing from Lee Mac (grsnap) to make the point selection loop have snaps, just now only snapping the first (start) point, also got to change the markers, currently Le Mcs default marker, text + a line, change top just text later.

 

  

  (defun make_blk_measure ( / )
    (if (not (tblsearch "STYLE" "$BLK_MEAS"))
      (entmake '((0 . "STYLE")
      (5 . "40")
      (100 . "AcDbSymbolTableRecord")
      (100 . "AcDbTextStyleTableRecord")
      (2 . "$BLK_MEAS")
      (70 . 0)
      (40 . 0.0)
      (41 . 0.7)
      (50 . 0.0)
      (71 . 0)
      (42 . 0.1)
      (3 . "ARIAL.TTF")
      (4 . "")
     )
      )
    )
    (if (not (tblsearch "BLOCK" "BLK_MEASURE_CURVE"))
      (progn
   (entmake
    '((0 . "BLOCK") (8 . "0") (2 . "BLK_MEASURE_CURVE") (70 . 2) (4 . "") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2) (10 0.0 0.0 0.0))
  )
  (entmake
    (append
      '((0 . "LINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2) (100 . "AcDbLine"))
      (list (list 10 0.0 (- (getvar "TEXTSIZE")) 0.0))
      (list (list 11 0.0 (getvar "TEXTSIZE") 0.0))
      '((210 0.0 0.0 1.0))
    )
   )
   (entmake
    '(
  (0 . "ATTDEF")
  (100 . "AcDbEntity")
  (67 . 0)
  (410 . "Model")
  (8 . "0")
  (62 . 0)
  (6 . "ByBlock")
  (370 . -2)
  (100 . "AcDbText")
  (10 0.0 0.0 0.0)
  (40 . 1.0)
  (1 . "0.0")
  (50 . 1.570796326794896)
  (41 . 0.7)
  (51 . 0.0)
  (7 . "$BLK_MEAS")
  (71 . 8)
  (72 . 1)
  (11 1.0 0.0 0.0)
  (210 0.0 0.0 1.0)
  (100 . "AcDbAttributeDefinition")
  (3 . "measure")
  (2 . "VALUE_MEASURE")
  (70 . 0)
  (73 . 0)
  (74 . 1)
    )
  )
  (entmake '((0 . "ENDBLK") (8 . "0") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2)))
      )
    )

    (if (not (tblsearch "BLOCK" "BLK_TICK_CURVE"))
      (progn
   (entmake
    '((0 . "BLOCK") (8 . "0") (2 . "BLK_TICK_CURVE") (70 . 2) (4 . "") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2) (10 0.0 0.0 0.0))
  )
  (entmake
    (append
      '((0 . "LINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2) (100 . "AcDbLine"))
      (list (list 10 0.0 (* 0.5 (- (getvar "TEXTSIZE"))) 0.0))
      (list (list 11 0.0 (* 0.5 (getvar "TEXTSIZE")) 0.0))
      '((210 0.0 0.0 1.0))
    )
  )
  (entmake '((0 . "ENDBLK") (8 . "0") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2)))
      )
    )
  )

(defun ptsel ( MyLine / gr break ptlst) ; Select Points l update with Lee Macs GrSnap function
  (princ "Select Points")
  (while (and (setq gr (grread T 4 2)) (not break))
    (cond
      ((= 3 (car gr))                                 ; left click
         (setq ptlst
                (if (= (length ptlst) 0)
                    (list (nearestpt MyLine (cadr gr)) )
                    (append ptlst (list (nearestpt MyLine (cadr gr)) ))
                ) ; end if
         ) ; end setq
         (princ (cadr gr))
         (princ "\nSelect Next Point or enter / space / right click")
      ) ; end cond
      ((or (member (car gr) '(12 25))                 ; right click
           (equal gr '(2 13))                         ; Enter
           (equal gr '(2 32))                         ; Space bar
       ) ; end cond
       (setq break T)
      ) ; end cond
    ) ; end conds
  ) ; end while
  ptlst
) ; end defun
(defun nearestpt ( line pt / ) ; Get nearsest point on a line
  (setq pt (vlax-curve-getclosestpointto line pt))
  pt
)
(defun linedistance ( MyLine / StartPt ptlist x templst dist_list ) ; dget distance along a line
  (setq StartPt (nearestpt MyLine (getpoint "Select Line Start Point"))) ; get point on line
  (setq StartDist (vlax-curve-getdistatpoint MyLine StartPt) )
  (setq ptlist (ptsel MyLine ))
  (setq templst (list StartDist))
  (foreach x ptlist
    (princ "\n")
    (setq Pt1Dist (vlax-curve-getdistatpoint MyLine x))
    (setq templst (append templst (list Pt1Dist)))
  )
  templst
)


;;https://www.cadtutor.net/forum/topic/1264-drawing-points-along-polyline/
(defun C:SPChainage ( / ang cumm_dist dis dist_list leng obj pt)
;; Set Attribute Value  -  Lee Mac
  (defun LM:setattributevalue ( blk tag val / enx )
      (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
          (if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
              (if (entmod (subst (cons 1 val) (assoc 1 (reverse enx)) enx))
                  (progn
                      (entupd blk)
                      val
                  ) ; end progn
              ) ; end if
              (LM:setattributevalue blk tag val)
          ) ; end if
      ) ; end if
  ) ; end defun

  (setq MyLine (car (entsel "Select a line")))
  (setq dist_list (linedistance MyLine))
  (setq obj (vlax-ename->vla-object MyLine))
  (setq lineleng (vlax-curve-getdistatpoint obj (vlax-curve-getendpoint obj)))

  (setq acount 0)
  (while (< acount (length dist_list))
    (setq dis (nth acount dist_list))
    (if (<= dis lineleng)(progn
      (setq pt (vlax-curve-getpointatdist obj dis)) ; can do better here, get points list from linedistance

;;make block
      (make_blk_measure)
      (setq ang (angle '(0 0 0) (vlax-curve-getfirstderiv obj (vlax-curve-getparamatpoint obj pt))))
      (vlax-invoke (vla-get-modelspace
        (vla-get-activedocument (vlax-get-acad-object))
      ) 'InsertBlock pt "BLK_MEASURE_CURVE" 1 1 1 ang)
      (setq MyLastBlock (entlast))
      (LM:setattributevalue MyLastBlock "VALUE_MEASURE" (strcat (rtos (+ acount 1)) ": " (rtos (abs (- dis (car dist_list))))) )
    )
    (progn
      (princ (strcat "Point " acount " is outside line"))
    )
    ) ; end progn, end if 
    (setq acount (+ acount 1))
  ) ; end while

  (princ)
)

 

Edited by Steven P
Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted

Just watch for : vlax-curve-getpointatdist function... Provided distance must not go above total length of curve, otherwise, return will be start point... This is bug in AutoCAD; BricsCAD returns nil which is correct...

  • Like 1
Link to comment
Share on other sites
Steven P Grand Master

Steven P

Posted
Posted

Thanks Marko, I wasn't sure what would happen but that explains something in another LISP that does occasionally do the odd thing. Will skip it or set it to the max distance

Link to comment
Share on other sites
Steven P Grand Master

Steven P

Posted
Posted (edited)

Try this, should be as your sample - except the text colour and layer will be to whatever you are using at the time.

 

Command SPChainage

 

 

  

;;Based on https://www.cadtutor.net/forum/topic/1264-drawing-points-along-polyline/
(defun C:SPChainage ( / ang cumm_dist dis dist_list leng obj pt)

  (setq textheight 20)


  (defun DegtoRad (numberOfDegrees / rad) 
    (setq rad (* pi (/ numberOfDegrees 180.0)))
    rad
  )
  (defun createtext ( MyText TextPoint textheight rad / )
    (entmake (list
      '(0 . "TEXT") '(100 . "AcDbEntity") '(8 . "0") '(100 . "AcDbText")
      (cons 10 TextPoint)
      (cons 40 textheight)
;;      '(46 . 0.0)
      (cons 1 MyText)
      (cons 50 rad) '(41 . 1.0) '(51 . 0.0)
;;     (cons 7 font)
      '(71 . 0) '(72 . 0)
      '(11 0.0 0.0 0.0) '(210 0.0 0.0 1.0) '(100 . "AcDbText") '(73 . 0)
    ));end list, entmake
  )
  (defun make_blk_measure ( / )
    (if (not (tblsearch "STYLE" "$BLK_MEAS"))
      (entmake 
        '((0 . "STYLE") (5 . "40") (100 . "AcDbSymbolTableRecord") (100 . "AcDbTextStyleTableRecord")
          (2 . "$BLK_MEAS") (70 . 0) (40 . 0.0) (41 . 0.7) (50 . 0.0) (71 . 0) (42 . 0.1) (3 . "ARIAL.TTF")
          (4 . "")
      ))
    ) ; end if
    (if (not (tblsearch "BLOCK" "BLK_MEASURE_CURVE"))
      (progn
        (entmake
          '((0 . "BLOCK") (8 . "0") (2 . "BLK_MEASURE_CURVE")
            (70 . 2) (4 . "") (8 . "0") (62 . 0) (6 . "ByBlock")
            (370 . -2) (10 0.0 0.0 0.0)
           )
        )
        (entmake
          (append
            '((0 . "LINE") (100 . "AcDbEntity") (67 . 0)
              (410 . "Model") (8 . "0") (62 . 0) (6 . "ByBlock")
              (370 . -2) (100 . "AcDbLine")
            )
            (list (list 10 0.0 (- (getvar "TEXTSIZE")) 0.0))
            (list (list 11 0.0 (getvar "TEXTSIZE") 0.0))
            '((210 0.0 0.0 1.0))
          )
        )
        (entmake
          '(
            (0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0")
            (62 . 0) (6 . "ByBlock") (370 . -2) (100 . "AcDbText") (10 0.0 0.0 0.0)
            (40 . 1.0) (1 . "0.0") (50 . 1.570796326794896) (41 . 0.7) (51 . 0.0)
            (7 . "$BLK_MEAS") (71 . 8) (72 . 1) (11 1.0 0.0 0.0) (210 0.0 0.0 1.0)
            (100 . "AcDbAttributeDefinition") (3 . "measure") (2 . "VALUE_MEASURE")
            (70 . 0) (73 . 0) (74 . 1)
          )
        )
        (entmake '((0 . "ENDBLK") (8 . "0") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2)))
      )
    )
    (if (not (tblsearch "BLOCK" "BLK_TICK_CURVE"))
      (progn
        (entmake
          '((0 . "BLOCK") (8 . "0") (2 . "BLK_TICK_CURVE") (70 . 2) (4 . "")
             (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2) (10 0.0 0.0 0.0))
        )
        (entmake (append
         '((0 . "LINE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0")
           (62 . 0) (6 . "ByBlock") (370 . -2) (100 . "AcDbLine"))
           (list (list 10 0.0 (* 0.5 (- (getvar "TEXTSIZE"))) 0.0))
           (list (list 11 0.0 (* 0.5 (getvar "TEXTSIZE")) 0.0))
           '((210 0.0 0.0 1.0))
         )
        )
        (entmake '((0 . "ENDBLK") (8 . "0") (8 . "0") (62 . 0) (6 . "ByBlock") (370 . -2)))
      ) ; end progn
    ) ; end if
  ) ; end defun
  (defun ptsel ( MyLine / result ptlst)
    (setvar "errno" 0)
    (setq ptlist (list))
    (while (/= 52 (getvar "errno"))
      (initget "eXit")
      (setq result (getpoint "\npick a point or [eXit] : "))
      (cond
        ((= 'list (type result))
          (setq ptlst (append ptlst (list (nearestpt MyLine result) )))
        ) ; end cond
          (t (setvar "errno" 52)
        ) ; end cond
      ) ; end conds
    ) ; end while
    ptlst
  ) ; end defun
  (defun nearestpt ( line pt / ) ; Get nearsest point on a line
    (setq pt (vlax-curve-getclosestpointto line pt))
    pt
  )
  (defun linedistance ( MyLine / StartPt ptlist x templst dist_list ) ; dget distance along a line
    (setq StartPt (nearestpt MyLine (getpoint "Select Line Start Point"))) ; get point on line
    (setq StartDist (vlax-curve-getdistatpoint MyLine StartPt) )
    (setq ptlist (ptsel MyLine ))
    (setq templst (list StartDist))
    (foreach x ptlist
      (princ "\n")
      (setq Pt1Dist (vlax-curve-getdistatpoint MyLine x))
      (setq templst (append templst (list Pt1Dist)))
    )
    templst
  )
;; Set Attribute Value  -  Lee Mac
  (defun LM:setattributevalue ( blk tag val / enx )
      (if (and (setq blk (entnext blk)) (= "ATTRIB" (cdr (assoc 0 (setq enx (entget blk))))))
          (if (= (strcase tag) (strcase (cdr (assoc 2 enx))))
              (if (entmod (subst (cons 1 val) (assoc 1 (reverse enx)) enx))
                  (progn
                      (entupd blk)
                      val
                  ) ; end progn
              ) ; end if
              (LM:setattributevalue blk tag val)
          ) ; end if
      ) ; end if
  ) ; end defun

  (setq MyLine (car (entsel "Select a line")))
  (setq dist_list (linedistance MyLine))
  (setq obj (vlax-ename->vla-object MyLine))
  (setq lineleng (vlax-curve-getdistatpoint obj (vlax-curve-getendpoint obj)))

  (setq acount 0)
  (while (< acount (length dist_list))
    (setq dis (nth acount dist_list))
    (if (>= dis lineleng) (setq dis lineleng)) ; set overlength point to the end
    (if (< dis 0) (setq dis 0)) ; set overlength point to the start
    (setq pt (vlax-curve-getpointatdist obj dis)) ; can do better here, get points list from linedistance

;;;make block
;    (make_blk_measure)
    (setq ang (angle '(0 0 0) (vlax-curve-getfirstderiv obj (vlax-curve-getparamatpoint obj pt))))
;    (vlax-invoke (vla-get-modelspace
;      (vla-get-activedocument (vlax-get-acad-object))
;    ) 'InsertBlock pt "BLK_MEASURE_CURVE" 1 1 1 ang)
;    (setq MyLastBlock (entlast))
;    (LM:setattributevalue MyLastBlock "VALUE_MEASURE" (strcat (rtos (+ acount 1)) ": " (rtos (abs (- dis (car dist_list))))) )

    (setq MyText (rtos (abs (- dis (car dist_list)))) )
    (createtext MyText pt textheight (+ ang (/ pi 2)) )

    (setq acount (+ acount 1))
  ) ; end while

  (princ)
)

 

 

 

On a technical thing - gave up on the grread idea I was using before - not something I have done before and only half works - great if you want to select a snap but not if you want the snaps off for a point (more reading needed)

Edited by Steven P
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...