Grading interpolation Lisp

May 14, 2020

Hi,

I am basically a newbie when it comes to complex lisp routines.I was wondering if anyone had / or know where I can get a lisp routines that works like or similar to this.

Pick point 1 then pick a grading elevation associated to point 1 (ei 235.56)

Pick point 2 then pick a grading elevation associated to point 2 (ei 236.87)

Pick a point between the first 2 points, insert a block at the point, then insert the interpolated value of that point based on the 2 points provided. (ei 236.23)

All this is done in 2D with no z values.

Anyone have anything that works like this or very similar?

Thanks in advance.

May 14, 2020

When you say "pick a grading elevation" - do you mean pick a TEXT object that contains the string that is the elevation?

Or would you just pick a point and ASK the user for the elevation?

This would be fairly simple to do. I don't know of one that is already written.

May 14, 2020

Perhaps this might help.

(defun c:foo  (/ pt1 el1 pt2 el2 pt3 pt4 2ddist deltaz slope)
  (setq pt1 (getpoint "\nPick first point: "))
  (setq el1 (getreal "\nEnter first point elevation "))
  (setq pt2 (getpoint "\nPick second point: "))
  (setq el2 (getreal "\nEnter second point elevation "))
  (setq pt3 (list (car pt1)(cadr pt1) el1))
  (setq pt4 (list (car pt2)(cadr pt2) el2))
  (setq	2ddist
	 (distance
	   (list (car pt3) (cadr pt3) 0.0)
	   (list (car pt4) (cadr pt4) 0.0)
	 )
  )
   (setq deltaz (distance
		 (list 0 0 (caddr pt3))
		 (list 0 0 (caddr pt4))
	       )
  )
  (setq slope (* 100.0 (/ deltaz 2ddist)))
  (alert (strcat (rtos slope 2 2) "% "))
)

May 14, 2020

52 minutes ago, rkmcswain said:

When you say "pick a grading elevation" - do you mean pick a TEXT object that contains the string that is the elevation?

Or would you just pick a point and ASK the user for the elevation?

Hi rkmcswain,

I mean pick a TEXT or MTEXT object that contains the grading number.

And return a grading number between the points. I dont need the slope at this moment, although what you posted works nicely for slope, which I can use to insert it as a text object.

I will see If I can draw this out using characters.

234.56 234.67 235.12

X---------------------------X----------------------------------------X

(PT1) (point returned from LISP) (PT2)

May 15, 2020

Something like this?

(vl-load-com)
;;;.....................................................................................................................
(defun IH:interpolateHeights  (mod / alg ang dmz doc dse dsi dss hge hgh hgs hgt hla hln msp obe obs obt pte pth pti pts
                               res rot rtt sla typ)
;;;.....................................................................................................................
;;; settings
  (setq hln "M_00_Pomocna")  ;layer
;;;.....................................................................................................................
;;; error handler
  (defun *error*  (msg /)
    (foreach i  (list obs obe)
      (if i
        (vla-highlight i :vlax-false)))
    (if dmz
      (setvar "DIMZIN" dmz))
    (if (not (member msg '("Function cancelled" "quit / exit abort")))
      (vl-exit-with-error (princ (strcat "\nError: " msg))))
    (princ))
;;;.....................................................................................................................
;;; subroutines
  ;; select text entity
  (defun IH:m-seltext  (msg / lop obx typ)
    (setq lop t)
    (while lop
      (if (setq obx (nentsel msg))
        (if (not (eq (type obx) 'STR))
          (progn (setq obx (vlax-ename->vla-object (car obx)))
                 (if (or (not obs) (not (eq (vla-get-handle obx) (vla-get-handle obs))))
                   (progn (setq typ (vla-get-objectname obx))
                          (if (wcmatch typ "AcDbText,AcDbMText")
                            (progn (setq hgt (vla-get-textString obx))
                                   (setq hgt (vl-string-trim " " hgt))
                                   (setq hgt (vl-string-subst "." " " hgt))
                                   (setq hgt (vl-string-subst "." "," hgt))
                                   (if (numberp (read hgt))
                                     (progn (setq lop nil) (vla-highlight obx :vlax-true))
                                     (princ "\nString in Text or MText is not number. ")))
                            (princ "\nEntity is not Text or MText. ")))
                   (princ "\nSame entity as the first one. ")))
          (setq lop nil))
        (if (eq (getvar "ERRNO") 7)
          (princ "\nNo selection. ")
          (exit))))
    obx)
  ;; get height from text string
  (defun IH:m-getHeight  (obx / hgt)
    (setq hgt (vla-get-textString obx))
    (setq hgt (vl-string-subst "." "," hgt))
    (setq hgt (atof hgt)))
  ;; get insertion point from text object
  (defun IH:m-getPoint  (obx / typ ptx)
    (setq typ (vla-get-objectname obx))
    (cond ((eq typ "AcDbText")
           (if (eq (vla-get-alignment obx) 0)
             (setq ptx (vla-get-insertionPoint obx))
             (setq ptx (vla-get-textAlignmentPoint obx))))
          ((eq typ "AcDbMText") (setq ptx (vla-get-insertionPoint obx))))
    (setq ptx (vlax-safearray->list (variant-value ptx)))
    (setq ptx (trans ptx 0 1)))
;;;.....................................................................................................................
;;; main
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq msp (vla-get-modelSpace doc))
  (setq rot (angle (trans '(0 0 0) 1 0) (trans '(1 0 0) 1 0)))
  (setq dmz (getvar "DIMZIN"))
  (setq obs (IH:m-seltext "\nSelect first point: "))
  (setq obe (IH:m-seltext "\nSelect second point: "))
  (setq hgs (IH:m-getHeight obs))
  (setq hge (IH:m-getHeight obe))
  (setq pts (IH:m-getPoint obs))
  (setq pte (IH:m-getPoint obe))
  (grdraw pts pte 5 0)
  (if (setq pti (getpoint "\nSpecify point to interpolate: "))
    (progn (setq pti (list (car pti) (cadr pti)))
           (setq ang (- (angle pts pte) rot))
           (setq dss (- (* (car pts) (cos ang)) (* (cadr pts) (sin ang))))
           (setq dse (- (* (car pte) (cos ang)) (* (cadr pte) (sin ang))))
           (setq pth (polar pti (+ (angle pts pte) (/ pi 2.0)) (distance pts pte)))
           (setq pth (inters pts pte pti pth nil))
           (grdraw pti pth 5 0)
           (grdraw pte pth 5 0)
           (setq dsi (- (* (car pth) (cos ang)) (* (cadr pth) (sin ang))))
           (setq res (+ hgs (* (/ (- hge hgs) (- dse dss)) (- dsi dss))))
           (setvar "DIMZIN" 0)
           (setq res (rtos res 2 2))
           (setq res (vl-string-subst "," "." res))
           (if mod
             (progn (setq sla (vla-get-layers doc))
                    (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list sla hln)))
                      (progn (setq hla (vla-add sla hln)) (vla-put-plottable hla :vlax-false) (vla-put-color hla 7)))
                    (setq hgh (vla-get-height obs))
                    (setq typ (vla-get-objectname obs))
                    (setq rtt (vla-get-rotation obs))
                    (cond ((eq typ "AcDbText")
                           (setq obt (vla-addText msp res (vlax-3d-point (trans pth 1 0)) hgh))
                           (vla-put-rotation obt rtt)
                           (if (not (eq (vla-get-alignment obs) 0))
                             (progn (vla-put-alignment obt alg)
                                    (vla-put-textAlignmentPoint obt (vlax-3d-point (trans pth 1 0))))))
                          ((eq typ "AcDbMText")
                           (setq obt (vla-addMText msp (vlax-3d-point (trans pth 1 0)) 0.0 res))
                           (vla-put-rotation obt rtt)
                           (vla-put-height obt hgh)
                           (vla-put-attachmentPoint obt (vla-get-attachmentPoint obs))
                           (vla-put-insertionPoint obt (vlax-3d-point (trans pth 1 0)))))
                    (vla-put-layer obt hln))
             (princ (strcat "\nHeight = " res)))))
  (vla-highlight obs :vlax-false)
  (vla-highlight obe :vlax-false)
  (setvar "DIMZIN" dmz)
  (princ))
;;;---------------------------------------------------------------------------------------------------------------------
(defun c:ipc (/) (IH:interpolateHeights nil))
(defun c:ipt (/) (IH:interpolateHeights t))

May 15, 2020

Hi Mara821,

Thats very close to what I need, except at our office we use a block for the point and plain text or mtext for the point data information.

It seems that lisp uses the insertion point of the text as the points to create the distance between the 2 texts.

I managed to cobble something together yesterday that seems to work, sort of. I am no pro at writing lisp so its very messy. If someone could help me clean it up that would be great.

(defun Radian->Degrees (nbrOfRadians)
  (* 180.0 (/ nbrOfRadians pi))
)
(defun C:IP (/ el1 e)
  (SETQ OS (GETVAR "OSMODE"))
	(SETVAR "OSMODE" 32 )
  (setq PT1 (getpoint "\nSelect first grade point:(LOWER GRADE POINT) "))
  (princ PT1)
  (if
    (and (setq EL1 (car (entsel "\nSelect grade text for first point: ")))
         (or (wcmatch (cdr (assoc 0 (setq e (entget EL1)))) "TEXT,MTEXT")
             (alert "Invlaid object. Try again")
         )
         (or (numberp
               (setq EL1 (distof (Clear_Mtext_String (cdr (assoc 1 e)))))
             )
             (alert "Invalid contents of text <!>")
         )
    )
     (princ EL1)
  )
  (setq PT2 (getpoint "\nSelect second grade point:(HIGHER GRADE POINT) "))
  (princ PT2)
  (princ)
  (if
    (and (setq EL2 (car (entsel "\nSelect grade text for second point: ")))
         (or (wcmatch (cdr (assoc 0 (setq e (entget EL2)))) "TEXT,MTEXT")
             (alert "Invlaid object. Try again")
         )
         (or (numberp
               (setq EL2 (distof (Clear_Mtext_String (cdr (assoc 1 e)))))
             )
             (alert "Invalid contents of text <!>")
         )
    )
     (princ EL2)
  )
  (SETVAR "OSMODE" 512 )
  (setq PT3 (getpoint "\nSelect Interpolated grade point:"))
  (setq ANG1 (angle PT1 PT2))
  (SETQ ANG2 (Radian->Degrees ANG1))
(setq dist (distance PT1 PT2))
(setq dist1 (distance PT2 PT3))

(IF (< EL1 EL2)
  (PROGN
  (SETQ EL3 (- EL2 EL1))
  )
  (SETQ EL3 (- EL1 EL2))
  )
  (SETQ EL4 (* DIST1 (/ EL3 DIST)))
  (SETQ EL5 (- EL2 EL4))
  (command "-layer" "S" "SWALE" "")
  (command "-insert" "Point_Cassidy" pt3 "" "" (+ ang2 45))
  (command "-layer" "S" "PROP-GRADE" "")
  (command ".text" PT3 ANG2 (RTOS EL5 2 2))
  (PRINC EL4)
  (PRINC)
)

(defun Clear_Mtext_String (String / Text Str)
  (setq Text "")
  (while (/= String "")
    (cond ((wcmatch (strcase (substr String 1 6)) "\\PXQC;")
           (setq String (substr String 7))
          )
          ((wcmatch (strcase (setq Str (substr String 1 2)))
                    "\\[\\{}`~]"
           )
           (setq String (substr String 3)
                 Text   (strcat Text Str)
           )
          )
          ((wcmatch (substr String 1 1) "[{}]")
           (setq String (substr String 2))
          )

          ((and (wcmatch (strcase (substr String 1 2)) "\\P")
                (/= (substr String 3 1) " ")
           )
           (setq String (substr String 3)
                 Text   (strcat Text " ")
           )
          )
          ((wcmatch (strcase (substr String 1 2)) "\\[LOP]")
           (setq String (substr String 3))
          )
          ((wcmatch (strcase (substr String 1 2)) "\\[ACFHQTW]")
           (setq String (substr String (+ 2 (vl-string-search ";" String))))
          )
          ((wcmatch (strcase (substr String 1 2)) "\\S")
           (setq Str    (substr String 3 (- (vl-string-search ";" String) 2))
                 Text   (strcat Text (vl-string-translate "#^\\" " " Str))
                 String (substr String (+ 4 (strlen Str)))
           )
           (print Str)
          )
          (T
           (setq Text   (strcat Text (substr String 1 1))
                 String (substr String 2)
           )
          )
    )
  )
  Text
)
(SETVAR "OSMODE" OS )
;;				;;
(vl-load-com)

May 16, 2020

Isn't it easier if you have an attribute at the block that denotes the elevation? If you're using a block as a point, then are you saying you're using its insertion point?

So if you just select the block, you can get its insertion point and also its attribute as well in one go.

May 16, 2020

Here's my attempt though

(defun c:interpolate (/	*error*	acadobj	activeundo	adoc	blkname	dis	elv1	elv2
			hgt1	hgt2	msp	newhgt	pm	pt1	pt2	pt3	tmpln
			txt)
    (defun *error* ( msg )
	(if tmpln (entdel tmpln))
	(vla-EndUndoMark adoc)
	(if (not (wcmatch (strcase msg T) "*break*,*cancel*,*exit*"))
	    (princ (strcat "Error: " msg))
	    )
	)
    (setq acadobj (vlax-get-acad-object)
	  adoc (vla-get-ActiveDocument acadobj)
	  msp (vla-get-ModelSpace adoc)
	  activeundo nil)
    (if (= 0 (logand 8 (getvar "UNDOCTL"))) (vla-StartUndoMark adoc) (setq activeundo T))

    ;; --------------------------- START ROUTINE --------------------------- ;;

    (setq blkname "<Your block name here>")
    
    (if
	(and
	    (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
		(alert "\nPlease unlock the current layer before proceeding!")
		T
		)
	    (setq pt1 (getpoint "\nSelect first point: "))
	    (and
		(setq elv1 (car (entsel "\nSelect first elevation text: ")))
		(if (null (wcmatch (cdr (assoc 0 (entget elv1))) "TEXT,MTEXT"))
		    (null (princ "\nObject is not a text"))
		    T)
		)
	    (setq pt2 (getpoint "\nSelect second point: "))
	    (and
		(setq elv2 (car (entsel "\nSelect second elevation text: ")))
		(if (null (wcmatch (cdr (assoc 0 (entget elv2))) "TEXT,MTEXT"))
		    (null (princ "\nObject is not a text"))
		    T)
		)
	    (setq tmpln
		     (entmakex
			 (list
			     '(0 . "LINE")
			     (cons 10 pt1)
			     (cons 11 pt2)
			     )
			 )
		  pt3 (getpoint "\nSpecify a point along the line to insert block: ")
		  )
	    (setq pm (vlax-curve-getParamAtPoint tmpln pt3))
	    (setq pm (/ pm (vlax-curve-getEndParam tmpln)))
	    )
	(progn
	    (setq txt (entget elv1)
		  hgt1 (car (LM:parsenumbers (cdr (assoc 1 (entget elv1)))))
		  hgt2 (car (LM:parsenumbers (cdr (assoc 1 (entget elv2)))))
		  dis (- hgt2 hgt1)
		  newhgt (+ hgt1 (* pm dis))
		  )
	    (entmake
		(append
		    (mapcar '(lambda (x) (assoc x txt)) '(0 8 40 50 7))
		    (list
			(cons 10 pt3)
			(cons 1 (rtos newhgt 2 2))
			)
		    )
		)
	    (if (tblsearch "block" blkname) (vla-InsertBlock msp (vlax-3d-point pt3) blkname 1.0 1.0 1.0 0.0)) 
	    )
	)

    (if tmpln (entdel tmpln))

    ;; --------------------------- END ROUTINE --------------------------- ;;
    
    (if activeundo nil (vla-EndUndoMark adoc))
    (princ)
    )


;; Parse Numbers  -  Lee Mac
;; Parses a list of numerical values from a supplied string.

(defun LM:parsenumbers ( str )
    (   (lambda ( l )
            (read
                (strcat "("
                    (vl-list->string
                        (mapcar
                           '(lambda ( a b c )
                                (if (or (< 47 b 58)
                                        (and (= 45 b) (< 47 c 58) (not (< 47 a 58)))
                                        (and (= 46 b) (< 47 a 58) (< 47 c 58))
                                    )
                                    b 32
                                )
                            )
                            (cons nil l) l (append (cdr l) '(()))
                        )
                    )
                    ")"
                )
            )
        )
        (vl-string->list str)
    )
)

Edited May 22, 2020 by Jonathan Handojo

May 18, 2020

Hi Jonathan,

Our office is a bit old school. And we use LT mostly.

I would love to transition to using Attributed blocks for our grade points but there are a lot of people that are too use to inserting a block for the X and text for the elevation heights. I am just trying to create something that can keep with our current standards that can be used on our 3 or 4 full versions as well as allow the people that use LT to keep with their ways.

Thanks for the help though. Don't have time at the moment to see if this fits my needs, but when I do I'll let you know.

May 19, 2020

16 hours ago, Strydaris said:

...And we use LT mostly.

You DO know that AutoCAD LT does not support AutoLISP - correct?

May 19, 2020

22 minutes ago, pkenewell said:

You DO know that AutoCAD LT does not support AutoLISP - correct?

Did you read my whole post before commenting or did you just read the first line?

Of course I know LT doesnt support lisp. If you read my whole comment you would of also read that we have 4 FULL VERSIONS in our office that DOES support AutoLISP.

The INTENT of the Lisp routine I would like to write is to make the end result be the exact same as the work someone would do if they did it on LT.

May 19, 2020

On 5/14/2020 at 3:04 PM, Strydaris said:

@Strydaris Sorry did not mean to offend you - just checking. Yes I missed that in your post.

May 19, 2020

2 hours ago, pkenewell said:

@Strydaris Sorry did not mean to offend you - just checking. Yes I missed that in your post.

@pkenewell No problem. Only reason why I am here is because I am not familiar enough with AutoLISP or VisualLisp to achieve what I need on my own.

I want to learn more but I dont have the time right now to get into it fully.

I especially need to understand more about the VisualLISP code as I have zero experience using that.

May 20, 2020

You can do some stuff using excel as it has VBA talking to LT you can paste the "ID" result pull it apart into XYZ then enter distance from end and work out a new XYZ for the point you then copy a column of the correct commands to the LT command line.

I have attached an example xls copy column D2-D5 and points will appear.

Book1.xlsx

Edited May 20, 2020 by BIGAL

May 22, 2020

Hi Johnathan,

See attached for a sample drawing.

I am zoomed into a section where I was testing the LISP.

just 2 points and a line.

The block name is Point_Cassidy

2017-36 - SG1 Sample.dwg

Sign In

Grading interpolation Lisp

Recommended Posts

Strydaris

rkmcswain

rkmcswain

Strydaris

Mara821

Strydaris

Jonathan Handojo

Jonathan Handojo

Strydaris

pkenewell

Strydaris

pkenewell

Strydaris

BIGAL

Strydaris

Join the conversation

Tutorials

Forums

Activity