Print Page - QUICK PROFILE LISP- hELP WITH UPDATE

Title: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on March 02, 2019, 06:31:14 AM

Hi i an using quick profile lisp (c) 2006 Pedro Ferreira

I add sone layers in the code and i want to do one more change, but i don't know how !!!

when the lisp start ask me to gine the name of the lcontours layer. when i create contours i have two layers
1 )Contour Major Natural Ground
2) Contour Minor Natural Ground

The question is

a) Is any way to understand this two layers automaticaly ?
b) or to select one contour of Contour Major Natural Ground layer and one contour os Contour Minor Natural Ground layer and the code understand the names of the layer ?

Code - Auto/Visual Lisp: [Select]

;;; CADALYST 09/06  Tip 2149: QuickProfile.lsp  Center Line Profile     (c) 2006 Pedro Ferreira 
 
 
;;;Author: Pedro Miguel da Silva Ferreira       Email:pedro_ferreira@netcabo.pt or pferreira@wsatkins.pt
;;;Web page: http:pwp.netcabo.pt/pedro_ferreira
;;;Location: Portugal, Lisboa
;;;RDS: PMSF
;;;Command Name: qp
;;;Date: 09 of May 2006
;;;Version: 1.0
;;;Description: Visual Lisp Routine that creates a section profile of the terrain based on the existing contours.
 
 
 
(defun timeini ()
  (setq s (getvar "DATE"))
  (setq seconds (* 86400.0 (- s (fix s))))
)
 
(defun timeend ()
  (setq s1 (getvar "DATE"))
  (setq seconds1 (* 86400.0 (- s1 (fix s1))))
  (setq seconds2 (fix (- seconds1 seconds)))
  (princ
    (strcat "\nTime : "
            (itoa seconds2)
            " seconds"
    )
  )
)
 
(defun inivar ()
  (setq cmd_ini (getvar "cmdecho")
        fla_ini (getvar "flatland")
        osm_ini (getvar "osmode")
        ort_ini (getvar "orthomode")
        plt_ini (getvar "plinetype")
        aup_ini (getvar "auprec")
        uni_ini (getvar "unitmode")
        lun_ini (getvar "lunits")
        diz_ini (getvar "dimzin")
        edg_ini (getvar "edgemode")
  )
  (setvar "CMDECHO" 0)
  (setvar "FLATLAND" 0)
  (setvar "OSMODE" 0)
  (setvar "ORTHOMODE" 0)
  (setvar "PLINETYPE" 2)
  (setvar "AUPREC" 0)
  (setvar "UNITMODE" 1)
  (setvar "LUNITS" 2)
  (setvar "DIMZIN" 0)
  (setvar "EDGEMODE" 1)
)
 
(defun recvar ()
  (setvar "CMDECHO" cmd_ini)
  (setvar "FLATLAND" fla_ini)
  (setvar "OSMODE" osm_ini)
  (setvar "ORTHOMODE" ort_ini)
  (setvar "PLINETYPE" plt_ini)
  (setvar "AUPREC" aup_ini)
  (setvar "UNITMODE" uni_ini)
  (setvar "LUNITS" lun_ini)
  (setvar "DIMZIN" diz_ini)
  (setvar "EDGEMODE" edg_ini)
)
 
(defun getlayname ()
  (setq contourstest nil)
  (setq layername
         (getstring
           "\nPlease enter the layer name of the contours: "
         )
  )
  (setq contourstest
         (ssget "_x"
                (list (cons -4 "<OR")
                      (cons -4 "<AND")
                      (cons 0 "lwpolyline")
                      (cons 8 layername)
                      (cons -4 "AND>")
                      (cons -4 "<AND")
                      (cons 0 "polyline")
                      (cons 8 layername)
                      (cons -4 "AND>")
                      (cons -4 "<AND")
                      (cons 0 "line")
                      (cons 8 layername)
                      (cons -4 "AND>")
                      (cons -4 "<AND")
                      (cons 0 "spline")
                      (cons 8 layername)
                      (cons -4 "AND>")
                      (cons -4 "OR>")
                )
         )
  )
 
  (while (= contourstest nil)
    (princ "\nNo contours selected...")
    (setq layername
           (getstring
             "\nPlease enter the layer name of the contours: "
           )
    )
    (setq contourstest
           (ssget "_x"
                  (list (cons -4 "<OR")
                        (cons -4 "<AND")
                        (cons 0 "lwpolyline")
                        (cons 8 layername)
                        (cons -4 "AND>")
                        (cons -4 "<AND")
                        (cons 0 "polyline")
                        (cons 8 layername)
                        (cons -4 "AND>")
                        (cons -4 "<AND")
                        (cons 0 "line")
                        (cons 8 layername)
                        (cons -4 "AND>")
                        (cons -4 "<AND")
                        (cons 0 "spline")
                        (cons 8 layername)
                        (cons -4 "AND>")
                        (cons -4 "OR>")
                  )
           )
    )
  )
)
 
(defun activexsupport ()
  (vl-load-com)
  (setq *modelspace*
         (vla-get-modelspace
           (vla-get-activedocument (vlax-get-acad-object))
         )
  )
)
 
(defun esttexto ()
 
  (vl-cmdf "._style" "PMSF-TEXT" "romans" 2.50 0.80 0 "n" "n" "n")
)
 
(defun getha ()
  ;; this entity must be a lwpolyline
  (activexsupport)
  (setq
    ha (entsel "\nSelect the Horizontal alignment: ")
  )
  (while (= ha nil)
    (progn
      (princ "\nNothing selected...")
      (setq ha
             (entsel "\nSelect the Horizontal alignment: ")
      )
    )
  )
  (setq ha-type (cdr (assoc 0 (entget (car ha)))))
  (if (not (equal ha-type "LWPOLYLINE"))
    (progn
      (setq ha nil)
      (princ "\n***Horizontal Alignment must be a LWPolyline***")
    )
  )
  (while (= ha nil)
    (progn
      (princ "\nNothing selected...")
      (setq ha
             (entsel "\nSelect the Horizontal alignment: ")
      )
      (setq ha-type (cdr (assoc 0 (entget (car ha)))))
      (if (not (equal ha-type "LWPOLYLINE"))
        (progn
          (setq ha nil)
          (princ "\n***Horizontal Alignment must be a LWPolyline***")
        )
      )
    )
  )
  (setq ha-ename (entget (car ha)))
  (setq ha-ename (cdr (assoc -1 ha-ename)))
  (setq ha-object (vlax-ename->vla-object ha-ename))
 
  (vl-cmdf "._text"
           (vlax-curve-getstartpoint ha-object)
           "0"
           "A"
  )
  (vl-cmdf "._text"
           (vlax-curve-getendpoint ha-object)
           "0"
           "B"
  )
)
 
(defun getexaggeration ()
  (initget 2)
  (setq ve (getreal "\nEnter the vertical exaggeration <1>: "))
  (if (= ve nil)
    (setq ve 1)
  )
)
 
 
(defun listptintersect ()
  (setq listaxy nil)
 
  (setq hazvalue (caddr (vlax-curve-getStartPoint ha-object)))
 
  (setq curvas contourstest)
  (setq ncurvas (sslength curvas))
  (setq listaxy nil)
  (setq counter 0)
  (while (< counter ncurvas)
    (progn
      (setq cnivel-ename (ssname curvas counter))
      (setq cnivel-object (vlax-ename->vla-object cnivel-ename))
 
      (setq cnivelzvalue
             (caddr (vlax-curve-getStartPoint cnivel-object))
      )
 
      (setq ha-ENTITY
             (subst (cons 38 cnivelzvalue)
                    (assoc 38 (entget (car ha)))
                    (entget (car ha))
             )
      )
      (entmod ha-ENTITY)
 
      (setq intersectpt
             (vlax-variant-value
               (vlax-invoke-method
                 ha-object
                 "IntersectWith"
                 cnivel-object
                 acExtendNone
               )
             )
      )
 
      (setq test nil)
      (setq
        test (vl-catch-all-apply
               'vlax-safearray->list
               (list intersectpt)
             )
      )
      (setq error (vl-catch-all-error-p test))
 
      (if (/= error t)
        (progn
          (setq intersectpt (vlax-safearray->list intersectpt))
          (setq interlength (length intersectpt))
 
          (if (> interlength 3)
            (progn
              (setq dividelength (/ interlength 3))
              (setq count 0)
              (while (< count interlength)
                (progn
                  (setq newpt (list (nth count intersectpt)
                                    (nth (+ count 1) intersectpt)
                                    (nth (+ count 2) intersectpt)
                              )
                  )
 
                  (setq x (vlax-curve-getdistatPoint ha-ename newpt))
                  (setq z (caddr intersectpt))
                  (setq xy (list x (* z ve)))
                  (setq
                    listaxy (append listaxy (list xy))
                  )
 
                  (setq count (+ count 3))
                )
              )
            )
            (progn
              (setq x (vlax-curve-getdistatPoint ha-ename intersectpt))
              (setq z (caddr intersectpt))
              (setq xy (list x (* z ve)))
              (setq
                listaxy (append listaxy (list xy))
              )
            )
          )
 
          (setq ha-ENTITY
                 (subst (cons 38 hazvalue)
                        (assoc 38 (entget (car ha)))
                        (entget (car ha))
                 )
          )
          (entmod ha-ENTITY)
        )
      )
      (setq counter (1+ counter))
    )
  )
 
  (setq listaxy
         (vl-sort listaxy
                  (function (lambda (e1 e2)
                              (< (car e1) (car e2))
                            )
                  )
         )
  )
 
  (setq startdist (vlax-curve-getdistatPoint
                    ha-ename
                    (vlax-curve-getstartpoint ha-ename)
                  )
        enddist   (vlax-curve-getdistatPoint
                    ha-ename
                    (vlax-curve-getendpoint ha-ename)
                  )
  )
 
  (setq pt1 (car (car listaxy))
        pt2 (car (last listaxy))
  )
 
  (if (/= startdist pt1)
    (progn
      (setq x startdist)
      (setq y (+ (* (/ (- (cadr (car listaxy)) (cadr (cadr listaxy)))
                       (- (car (cadr listaxy)) (car (car listaxy)))
                    )
                    (- (car (car listaxy)) startdist)
                 )
                 (cadr (car listaxy))
              )
      )
      (setq xy (list x y))
      (setq
        listaxy (append listaxy (list xy))
      )
      (setq listaxy
             (vl-sort listaxy
                      (function (lambda (e1 e2)
                                  (< (car e1) (car e2))
                                )
                      )
             )
      )
 
    )
  )
 
  (if (/= enddist pt1)
    (progn
      (setq pos (1- (length listaxy)))
      (setq x enddist)
      (setq y
             (+
               (*
                 (/ (- (cadr (nth pos listaxy))
                       (cadr (nth (1- pos) listaxy))
                    )
                    (- (car (nth pos listaxy)) (car (nth (1- pos) listaxy)))
                 )
                 (- enddist (car (nth pos listaxy)))
               )
               (cadr (nth pos listaxy))
             )
      )
      (setq xy (list x y))
      (setq
        listaxy (append listaxy (list xy))
      )
      (setq listaxy
             (vl-sort listaxy
                      (function (lambda (e1 e2)
                                  (< (car e1) (car e2))
                                )
                      )
             )
      )
 
    )
  )
)
 
(defun createprofile ()
(COMMAND "_layer" "_m" "NATURAL GROUND" "_c" "94" "" "")
  (setq variante-listaxy (apply 'append listaxy))
 
  (setq arraySpace
         (vlax-make-safearray
           vlax-vbdouble
           (cons 0
                 (- (length variante-listaxy) 1)
           )
         )
  )
  (setq variante-listaxy
         (vlax-safearray-fill arraySpace variante-listaxy)
  )
 
  (vlax-make-variant variante-listaxy)
 
 
  (setq pline (vla-addLightweightPolyline
                *ModelSpace*
                variante-listaxy
              )
  )
 
 
  (vl-cmdf "._text"
           (vlax-curve-getstartpoint pline)
           "0"
           "A"
  )
  (vl-cmdf "._text"
           (vlax-curve-getendpoint pline)
           "0"
           "B"
  )
)
 
(defun annotate ()
  (setq xini (car (vlax-curve-getstartpoint pline))
        xend (car (vlax-curve-getendpoint pline))
        y    (* (fix
                  (/ (cadr (car (vl-sort listaxy
                                         (function (lambda (e1 e2)
                                                     (< (cadr e1) (cadr e2))
                                                   )
                                         )
                                )
                           )
                     )
                     ve
                  )
                )
                ve
             )
  )
  ;;end setq
 
  (if (< y 0)
    (setq y (- y (* 1 ve)))
  )
 
  (setq var-xyini (apply 'append (list (list xini y 0))))
  (setq var-xyend (apply 'append (list (list xend y 0))))
  (createline)
  (COMMAND "_layer" "_m" "REFERENCE" "_c" "12" "" "")
  (setq yref (strcat "REFERENCE: " (rtos (/ y ve) 2 2)))
  (setq ptloc (list (- xini 30.0) y))
  (vl-cmdf "._text" ptloc "0" yref)
 
 
 
 
  (setq lengthlistaxy (length listaxy))
  (setq count 0)
  (while (< count lengthlistaxy)
    (progn
      (setq var-xyini (apply 'append
                             (list (list (car (nth count listaxy))
                                         (cadr (nth count listaxy))
                                         0
                                   )
                             )
                      )
      )
      (setq
        var-xyend (apply 'append
                         (list (list (car (nth count listaxy)) y 0))
                  )
      )
      (createline)
(COMMAND "_layer" "_m" "NATURAL GROUND ELEV TEXT" "_c" "94" "" "")
      (setq ytext (rtos (/ (cadr (nth count listaxy)) ve) 2 2))
      (setq xpt (car (nth count listaxy)))
      (setq ptloc (list xpt (- y 10.0)))
      (vl-cmdf "._text" ptloc "90" ytext)
 
      (setq count (1+ count))
    )
  )
 
 
 
 
)
 
 
 
(defun createline ()
(COMMAND "_layer" "_m" "LINE" "_c" "155" "" "")
  (setq arraySpace
         (vlax-make-safearray
           vlax-vbdouble
           (cons 0
                 (- (length var-xyini) 1)
           )
         )
  )
  (setq var-xyini
         (vlax-safearray-fill arraySpace var-xyini)
  )
 
  (vlax-make-variant var-xyini)
 
  (setq arraySpace
         (vlax-make-safearray
           vlax-vbdouble
           (cons 0
                 (- (length var-xyend) 1)
           )
         )
  )
  (setq var-xyend
         (vlax-safearray-fill arraySpace var-xyend)
  )
 
  (vlax-make-variant var-xyend)
 
  (setq line (vla-addline
               *ModelSpace*
               var-xyini
               var-xyend
             )
  )
 
)
 
 
 
 
(defun c:qp ()
  (timeini)
  (inivar)
  (getlayname)
  (esttexto)
  (getha)
  (getexaggeration)
  (listptintersect)
  (createprofile)
  (annotate)
 
  (vl-cmdf "._zoom"
           (vlax-curve-getstartpoint pline)
           (vlax-curve-getendpoint pline)
  )
  (recvar)
  (timeend)
  (command "setvar" "clayer" "0")
  (princ)
)
 
 

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: kdub_nz on March 02, 2019, 02:20:17 PM

Topographer,
I can't understand your question. Can you please add a little more detail about what you want.

In the routine "createprofile ()" you create layer "NATURAL GROUND".
How do you want this to be changed ??

What exactly is the difference in usage between the 2 layers ( Major and Minor ) you want to use.??

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on March 02, 2019, 03:29:47 PM

Hi kdub. The lisp i use to create contous create two layers , Contour Major Natural Ground and Contour Minor Natural Ground

The quick profile lisp ask to give one layer name for the contours. I want to change this. And i ask

a) Is any way to understand this two layers automaticaly ?
b) or to select one contour of Contour Major Natural Ground layer and one contour os Contour Minor Natural Ground layer and the code understand the names of the layer ?

Thanks

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: kdub_nz on March 02, 2019, 05:18:17 PM

I'll try again.
Do you want the user to select the layer to use instead of "NATURAL GROUND" ?

OR do you want to use both ot 'your' layers instead ?

if the latter, which parts do you want drawn to use which layer ?

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on March 02, 2019, 05:38:00 PM

The lisp ask

Code - Auto/Visual Lisp: [Select]

(setq   layername
         (getstring
           "\nPlease enter the layer name of the contours: "
         )
 

I have two contour layers with names

a)Contour Major Natural Ground
b)Contour Minor Natural Ground

I want to select both of them

Thanks

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: sanju2323 on March 03, 2019, 01:32:00 AM

Topographer,
Try, it will work.

Code: [Select]

;;; CADALYST 09/06  Tip 2149: QuickProfile.lsp  Center Line Profile	(c) 2006 Pedro Ferreira 
 
 
;;;Author: Pedro Miguel da Silva Ferreira	Email:pedro_ferreira@netcabo.pt or pferreira@wsatkins.pt
;;;Web page: http:pwp.netcabo.pt/pedro_ferreira
;;;Location: Portugal, Lisboa
;;;RDS: PMSF
;;;Command Name: qp
;;;Date: 09 of May 2006
;;;Version: 1.0
;;;Description: Visual Lisp Routine that creates a section profile of the terrain based on the existing contours.
 
 
 
(defun timeini ()
  (setq s (getvar "DATE"))
  (setq seconds (* 86400.0 (- s (fix s))))
)
 
(defun timeend ()
  (setq s1 (getvar "DATE"))
  (setq seconds1 (* 86400.0 (- s1 (fix s1))))
  (setq seconds2 (fix (- seconds1 seconds)))
  (princ
    (strcat "\nTime : "
	    (itoa seconds2)
	    " seconds"
    )
  )
)
 
(defun inivar ()
  (setq	cmd_ini	(getvar "cmdecho")
	fla_ini	(getvar "flatland")
	osm_ini	(getvar "osmode")
	ort_ini	(getvar "orthomode")
	plt_ini	(getvar "plinetype")
	aup_ini	(getvar "auprec")
	uni_ini	(getvar "unitmode")
	lun_ini	(getvar "lunits")
	diz_ini	(getvar "dimzin")
	edg_ini	(getvar "edgemode")
  )
  (setvar "CMDECHO" 0)
  (setvar "FLATLAND" 0)
  (setvar "OSMODE" 0)
  (setvar "ORTHOMODE" 0)
  (setvar "PLINETYPE" 2)
  (setvar "AUPREC" 0)
  (setvar "UNITMODE" 1)
  (setvar "LUNITS" 2)
  (setvar "DIMZIN" 0)
  (setvar "EDGEMODE" 1)
)
 
(defun recvar ()
  (setvar "CMDECHO" cmd_ini)
  (setvar "FLATLAND" fla_ini)
  (setvar "OSMODE" osm_ini)
  (setvar "ORTHOMODE" ort_ini)
  (setvar "PLINETYPE" plt_ini)
  (setvar "AUPREC" aup_ini)
  (setvar "UNITMODE" uni_ini)
  (setvar "LUNITS" lun_ini)
  (setvar "DIMZIN" diz_ini)
  (setvar "EDGEMODE" edg_ini)
)
 
(defun getlayname ()
  (setq contourstest nil)
;  (setq	layername
;	 (getstring
;	   "\nPlease enter the layer name of the contours: "
;	 )
;  )
  (setq	contourstest
	 (ssget	"_x"
		(list (cons -4 "<OR")
		      (cons -4 "<AND")
		      (cons 0 "lwpolyline")
		      (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
		      (cons -4 "AND>")
		      (cons -4 "<AND")
		      (cons 0 "polyline")
		      (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
		      (cons -4 "AND>")
		      (cons -4 "<AND")
		      (cons 0 "line")
		      (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
		      (cons -4 "AND>")
		      (cons -4 "<AND")
		      (cons 0 "spline")
		      (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
		      (cons -4 "AND>")
		      (cons -4 "OR>")
		)
	 )
  )
 
  (while (= contourstest nil)
    (princ "\nNo contours selected...")
;    (setq layername
;	   (getstring
;	     "\nPlease enter the layer name of the contours: "
;	   )
;    )
    (setq contourstest
	   (ssget "_x"
		  (list	(cons -4 "<OR")
			(cons -4 "<AND")
			(cons 0 "lwpolyline")
		        (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
			(cons -4 "AND>")
			(cons -4 "<AND")
			(cons 0 "polyline")
		        (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
			(cons -4 "AND>")
			(cons -4 "<AND")
			(cons 0 "line")
		        (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
			(cons -4 "AND>")
			(cons -4 "<AND")
			(cons 0 "spline")
		        (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
			(cons -4 "AND>")
			(cons -4 "OR>")
		  )
	   )
    )
  )
)
 
(defun activexsupport ()
  (vl-load-com)
  (setq	*modelspace*
	 (vla-get-modelspace
	   (vla-get-activedocument (vlax-get-acad-object))
	 )
  )
)
 
(defun esttexto	()
 
  (vl-cmdf "._style" "PMSF-TEXT" "romans" 2.50 0.80 0 "n" "n" "n")
)
 
(defun getha ()
  ;; this entity must be a lwpolyline
  (activexsupport)
  (setq
    ha (entsel "\nSelect the Horizontal alignment: ")
  )
  (while (= ha nil)
    (progn
      (princ "\nNothing selected...")
      (setq ha
	     (entsel "\nSelect the Horizontal alignment: ")
      )
    )
  )
  (setq ha-type (cdr (assoc 0 (entget (car ha)))))
  (if (not (equal ha-type "LWPOLYLINE"))
    (progn
      (setq ha nil)
      (princ "\n***Horizontal Alignment must be a LWPolyline***")
    )
  )
  (while (= ha nil)
    (progn
      (princ "\nNothing selected...")
      (setq ha
	     (entsel "\nSelect the Horizontal alignment: ")
      )
      (setq ha-type (cdr (assoc 0 (entget (car ha)))))
      (if (not (equal ha-type "LWPOLYLINE"))
	(progn
	  (setq ha nil)
	  (princ "\n***Horizontal Alignment must be a LWPolyline***")
	)
      )
    )
  )
  (setq ha-ename (entget (car ha)))
  (setq ha-ename (cdr (assoc -1 ha-ename)))
  (setq ha-object (vlax-ename->vla-object ha-ename))
 
  (vl-cmdf "._text"
	   (vlax-curve-getstartpoint ha-object)
	   "0"
	   "A"
  )
  (vl-cmdf "._text"
	   (vlax-curve-getendpoint ha-object)
	   "0"
	   "B"
  )
)
 
(defun getexaggeration ()
  (initget 2)
  (setq ve (getreal "\nEnter the vertical exaggeration <1>: "))
  (if (= ve nil)
    (setq ve 1)
  )
)
 
 
(defun listptintersect ()
  (setq listaxy nil)
 
  (setq hazvalue (caddr (vlax-curve-getStartPoint ha-object)))
 
  (setq curvas contourstest)
  (setq ncurvas (sslength curvas))
  (setq listaxy nil)
  (setq counter 0)
  (while (< counter ncurvas)
    (progn
      (setq cnivel-ename (ssname curvas counter))
      (setq cnivel-object (vlax-ename->vla-object cnivel-ename))
 
      (setq cnivelzvalue
	     (caddr (vlax-curve-getStartPoint cnivel-object))
      )
 
      (setq ha-ENTITY
	     (subst (cons 38 cnivelzvalue)
		    (assoc 38 (entget (car ha)))
		    (entget (car ha))
	     )
      )
      (entmod ha-ENTITY)
 
      (setq intersectpt
	     (vlax-variant-value
	       (vlax-invoke-method
		 ha-object
		 "IntersectWith"
		 cnivel-object
		 acExtendNone
	       )
	     )
      )
 
      (setq test nil)
      (setq
	test (vl-catch-all-apply
	       'vlax-safearray->list
	       (list intersectpt)
	     )
      )
      (setq error (vl-catch-all-error-p test))
 
      (if (/= error t)
	(progn
	  (setq intersectpt (vlax-safearray->list intersectpt))
	  (setq interlength (length intersectpt))
 
	  (if (> interlength 3)
	    (progn
	      (setq dividelength (/ interlength 3))
	      (setq count 0)
	      (while (< count interlength)
		(progn
		  (setq	newpt (list (nth count intersectpt)
				    (nth (+ count 1) intersectpt)
				    (nth (+ count 2) intersectpt)
			      )
		  )
 
		  (setq x (vlax-curve-getdistatPoint ha-ename newpt))
		  (setq z (caddr intersectpt))
		  (setq xy (list x (* z ve)))
		  (setq
		    listaxy (append listaxy (list xy))
		  )
 
		  (setq count (+ count 3))
		)
	      )
	    )
	    (progn
	      (setq x (vlax-curve-getdistatPoint ha-ename intersectpt))
	      (setq z (caddr intersectpt))
	      (setq xy (list x (* z ve)))
	      (setq
		listaxy	(append listaxy (list xy))
	      )
	    )
	  )
 
	  (setq	ha-ENTITY
		 (subst	(cons 38 hazvalue)
			(assoc 38 (entget (car ha)))
			(entget (car ha))
		 )
	  )
	  (entmod ha-ENTITY)
	)
      )
      (setq counter (1+ counter))
    )
  )
 
  (setq	listaxy
	 (vl-sort listaxy
		  (function (lambda (e1 e2)
			      (< (car e1) (car e2))
			    )
		  )
	 )
  )
 
  (setq	startdist (vlax-curve-getdistatPoint
		    ha-ename
		    (vlax-curve-getstartpoint ha-ename)
		  )
	enddist	  (vlax-curve-getdistatPoint
		    ha-ename
		    (vlax-curve-getendpoint ha-ename)
		  )
  )
 
  (setq	pt1 (car (car listaxy))
	pt2 (car (last listaxy))
  )
 
  (if (/= startdist pt1)
    (progn
      (setq x startdist)
      (setq y (+ (* (/ (- (cadr (car listaxy)) (cadr (cadr listaxy)))
		       (- (car (cadr listaxy)) (car (car listaxy)))
		    )
		    (- (car (car listaxy)) startdist)
		 )
		 (cadr (car listaxy))
	      )
      )
      (setq xy (list x y))
      (setq
	listaxy	(append listaxy (list xy))
      )
      (setq listaxy
	     (vl-sort listaxy
		      (function	(lambda	(e1 e2)
				  (< (car e1) (car e2))
				)
		      )
	     )
      )
 
    )
  )
 
  (if (/= enddist pt1)
    (progn
      (setq pos (1- (length listaxy)))
      (setq x enddist)
      (setq y
	     (+
	       (*
		 (/ (- (cadr (nth pos listaxy))
		       (cadr (nth (1- pos) listaxy))
		    )
		    (- (car (nth pos listaxy)) (car (nth (1- pos) listaxy)))
		 )
		 (- enddist (car (nth pos listaxy)))
	       )
	       (cadr (nth pos listaxy))
	     )
      )
      (setq xy (list x y))
      (setq
	listaxy	(append listaxy (list xy))
      )
      (setq listaxy
	     (vl-sort listaxy
		      (function	(lambda	(e1 e2)
				  (< (car e1) (car e2))
				)
		      )
	     )
      )
 
    )
  )
)
 
(defun createprofile ()
(COMMAND "_layer" "_m" "NATURAL GROUND" "_c" "94" "" "")
  (setq variante-listaxy (apply 'append listaxy))
 
  (setq	arraySpace
	 (vlax-make-safearray
	   vlax-vbdouble
	   (cons 0
		 (- (length variante-listaxy) 1)
	   )
	 )
  )
  (setq	variante-listaxy
	 (vlax-safearray-fill arraySpace variante-listaxy)
  )
 
  (vlax-make-variant variante-listaxy)
 
 
  (setq	pline (vla-addLightweightPolyline
		*ModelSpace*
		variante-listaxy
	      )
  )
 
 
  (vl-cmdf "._text"
	   (vlax-curve-getstartpoint pline)
	   "0"
	   "A"
  )
  (vl-cmdf "._text"
	   (vlax-curve-getendpoint pline)
	   "0"
	   "B"
  )
)
 
(defun annotate	()
  (setq	xini (car (vlax-curve-getstartpoint pline))
	xend (car (vlax-curve-getendpoint pline))
	y    (*	(fix
		  (/ (cadr (car	(vl-sort listaxy
					 (function (lambda (e1 e2)
						     (< (cadr e1) (cadr e2))
						   )
					 )
				)
			   )
		     )
		     ve
		  )
		)
		ve
	     )
  )
  ;;end setq
 
  (if (< y 0)
    (setq y (- y (* 1 ve)))
  )
 
  (setq var-xyini (apply 'append (list (list xini y 0))))
  (setq var-xyend (apply 'append (list (list xend y 0))))
  (createline)
  (COMMAND "_layer" "_m" "REFERENCE" "_c" "12" "" "")
  (setq yref (strcat "REFERENCE: " (rtos (/ y ve) 2 2)))
  (setq ptloc (list (- xini 30.0) y))
  (vl-cmdf "._text" ptloc "0" yref)
 
 
 
 
  (setq lengthlistaxy (length listaxy))
  (setq count 0)
  (while (< count lengthlistaxy)
    (progn
      (setq var-xyini (apply 'append
			     (list (list (car (nth count listaxy))
					 (cadr (nth count listaxy))
					 0
				   )
			     )
		      )
      )
      (setq
	var-xyend (apply 'append
			 (list (list (car (nth count listaxy)) y 0))
		  )
      )
      (createline)
(COMMAND "_layer" "_m" "NATURAL GROUND ELEV TEXT" "_c" "94" "" "")
      (setq ytext (rtos (/ (cadr (nth count listaxy)) ve) 2 2))
      (setq xpt (car (nth count listaxy)))
      (setq ptloc (list xpt (- y 10.0)))
      (vl-cmdf "._text" ptloc "90" ytext)
 
      (setq count (1+ count))
    )
  )
 
 
 
 
)
 
 
 
(defun createline ()
(COMMAND "_layer" "_m" "LINE" "_c" "155" "" "")
  (setq	arraySpace
	 (vlax-make-safearray
	   vlax-vbdouble
	   (cons 0
		 (- (length var-xyini) 1)
	   )
	 )
  )
  (setq	var-xyini
	 (vlax-safearray-fill arraySpace var-xyini)
  )
 
  (vlax-make-variant var-xyini)
 
  (setq	arraySpace
	 (vlax-make-safearray
	   vlax-vbdouble
	   (cons 0
		 (- (length var-xyend) 1)
	   )
	 )
  )
  (setq	var-xyend
	 (vlax-safearray-fill arraySpace var-xyend)
  )
 
  (vlax-make-variant var-xyend)
 
  (setq	line (vla-addline
	       *ModelSpace*
	       var-xyini
	       var-xyend
	     )
  )
 
)
 
 
 
 
(defun c:qp ()
  (timeini)
  (inivar)
  (getlayname)
  (esttexto)
  (getha)
  (getexaggeration)
  (listptintersect)
  (createprofile)
  (annotate)
 
  (vl-cmdf "._zoom"
	   (vlax-curve-getstartpoint pline)
	   (vlax-curve-getendpoint pline)
  )
  (recvar)
  (timeend)
  (command "setvar" "clayer" "0")
  (princ)
)

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on March 03, 2019, 02:47:05 AM

Thank you sanju2323 :-D

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: sanju2323 on March 03, 2019, 10:30:36 AM

Topographer, I would like to present you a small update.
It will work even if there is a contour in any layer.

Code: [Select]

;;;Author: Pedro Miguel da Silva Ferreira	Email:pedro_ferreira@netcabo.pt or pferreira@wsatkins.pt
;;;Web page: http:pwp.netcabo.pt/pedro_ferreira
;;;Location: Portugal, Lisboa
;;;RDS: PMSF
;;;Command Name: qp
;;;Date: 09 of May 2006
;;;Version: 1.0
;;;Description: Visual Lisp Routine that creates a section profile of the terrain based on the existing contours.
;;;Modified 11/20/09 CAB request of ttxxx of AutoLisp Forum, to print chainage info, tabular form


(defun timeini ()
  (setq s (getvar "DATE"))
  (setq seconds (* 86400.0 (- s (fix s))))
)

(defun timeend ()
  (setq s1 (getvar "DATE"))
  (setq seconds1 (* 86400.0 (- s1 (fix s1))))
  (setq seconds2 (fix (- seconds1 seconds)))
  (princ
    (strcat "\nTime : "
	    (itoa seconds2)
	    " seconds"
    )
  )
)

(defun inivar ()
  (setq	cmd_ini	(getvar "cmdecho")
	fla_ini	(getvar "flatland")
	osm_ini	(getvar "osmode")
	ort_ini	(getvar "orthomode")
	plt_ini	(getvar "plinetype")
	aup_ini	(getvar "auprec")
	uni_ini	(getvar "unitmode")
	lun_ini	(getvar "lunits")
	diz_ini	(getvar "dimzin")
	edg_ini	(getvar "edgemode")
  )
  (setvar "CMDECHO" 0)
  (setvar "FLATLAND" 0)
  (setvar "OSMODE" 0)
  (setvar "ORTHOMODE" 0)
  (setvar "PLINETYPE" 2)
  (setvar "AUPREC" 0)
  (setvar "UNITMODE" 1)
  (setvar "LUNITS" 2)
  (setvar "DIMZIN" 0)
  (setvar "EDGEMODE" 1)
)

(defun recvar ()
  (setvar "CMDECHO" cmd_ini)
  (setvar "FLATLAND" fla_ini)
  (setvar "OSMODE" osm_ini)
  (setvar "ORTHOMODE" ort_ini)
  (setvar "PLINETYPE" plt_ini)
  (setvar "AUPREC" aup_ini)
  (setvar "UNITMODE" uni_ini)
  (setvar "LUNITS" lun_ini)
  (setvar "DIMZIN" diz_ini)
  (setvar "EDGEMODE" edg_ini)
)

;; Unique  -  Lee Mac
;; Returns a list with duplicate elements removed.
(defun LM:Unique (l / x r)
  (while l
    (setq x (car l)
	  l (vl-remove x (cdr l))
	  r (cons x r)
    )
  )
  (reverse r)
)

(defun getlayname (/ selset lyrset n ent)
  (setq contourstest nil)
  (while (= contourstest nil)
    (prompt "\nSelect one or more entities to get Contours Layer(s) : ")
    (setq selset (ssget "_X" (list (cons 0 "*LINE")))) ;(setq selset (ssget "_:L" '((0 . "*LINE"))))
    (setq lyrset (list))
    (repeat (setq n (sslength selset))
      (setq ent (ssname selset (setq n (1- n))))
      (setq lyrset (append lyrset (list (vla-get-layer (vlax-ename->vla-object ent)))))
    )
    (setq lyrset (LM:Unique lyrset))
    (setq contourstest
	   (ssget "_X"
		  (append '((0 . "*LINE") (-4 . "<OR")) (mapcar '(lambda (n) (cons 8 n)) lyrset) '((-4 . "OR>")))
	   )
    )
  )
)

(defun activexsupport ()
  (vl-load-com)
  (setq	*modelspace*
	 (vla-get-modelspace
	   (vla-get-activedocument (vlax-get-acad-object))
	 )
  )
)

(defun esttexto	()

  (vl-cmdf "._style" "PMSF-TEXT" "romans" 2.50 0.80 0 "n" "n" "n")
)

(defun getha ()
  ;; this entity must be a lwpolyline
  (activexsupport)
  (setq
    ha (entsel "\nSelect the Horizontal alignment: ")
  )
  (while (= ha nil)
    (progn
      (princ "\nNothing selected...")
      (setq ha
	     (entsel "\nSelect the Horizontal alignment: ")
      )
    )
  )
  (setq ha-type (cdr (assoc 0 (entget (car ha)))))
  (if (not (equal ha-type "LWPOLYLINE"))
    (progn
      (setq ha nil)
      (princ "\n***Horizontal Alignment must be a LWPolyline***")
    )
  )
  (while (= ha nil)
    (progn
      (princ "\nNothing selected...")
      (setq ha
	     (entsel "\nSelect the Horizontal alignment: ")
      )
      (setq ha-type (cdr (assoc 0 (entget (car ha)))))
      (if (not (equal ha-type "LWPOLYLINE"))
	(progn
	  (setq ha nil)
	  (princ "\n***Horizontal Alignment must be a LWPolyline***")
	)
      )
    )
  )
  (setq ha-ename (entget (car ha)))
  (setq ha-ename (cdr (assoc -1 ha-ename)))
  (setq ha-object (vlax-ename->vla-object ha-ename))

  (vl-cmdf "._text"
	   (vlax-curve-getstartpoint ha-object)
	   "0"
	   "A"
  )
  (vl-cmdf "._text"
	   (vlax-curve-getendpoint ha-object)
	   "0"
	   "B"
  )
)

(defun getexaggeration ()
  (initget 2)
  (setq ve (getreal "\nEnter the vertical exaggeration <1>: "))
  (if (= ve nil)
    (setq ve 1)
  )
)


(defun listptintersect ()
  (setq listaxy nil)

  (setq hazvalue (caddr (vlax-curve-getStartPoint ha-object)))

  (setq curvas contourstest)
  (setq ncurvas (sslength curvas))
  (setq listaxy nil)
  (setq counter 0)
  (while (< counter ncurvas)
    (progn
      (setq cnivel-ename (ssname curvas counter))
      (setq cnivel-object (vlax-ename->vla-object cnivel-ename))

      (setq cnivelzvalue
	     (caddr (vlax-curve-getStartPoint cnivel-object))
      )

      (setq ha-ENTITY
	     (subst (cons 38 cnivelzvalue)
		    (assoc 38 (entget (car ha)))
		    (entget (car ha))
	     )
      )
      (entmod ha-ENTITY)

      (setq intersectpt
	     (vlax-variant-value
	       (vlax-invoke-method
		 ha-object
		 "IntersectWith"
		 cnivel-object
		 acExtendNone
	       )
	     )
      )

      (setq test nil)
      (setq
	test (vl-catch-all-apply
	       'vlax-safearray->list
	       (list intersectpt)
	     )
      )
      (setq error (vl-catch-all-error-p test))

      (if (/= error t)
	(progn
	  (setq intersectpt (vlax-safearray->list intersectpt))
	  (setq interlength (length intersectpt))

	  (if (> interlength 3)
	    (progn
	      (setq dividelength (/ interlength 3))
	      (setq count 0)
	      (while (< count interlength)
		(progn
		  (setq	newpt (list (nth count intersectpt)
				    (nth (+ count 1) intersectpt)
				    (nth (+ count 2) intersectpt)
			      )
		  )

		  (setq x (vlax-curve-getdistatPoint ha-ename newpt))
		  (setq z (caddr intersectpt))
		  (setq xy (list x (* z ve)))
		  (setq
		    listaxy (append listaxy (list xy))
		  )

		  (setq count (+ count 3))
		)
	      )
	    )
	    (progn
	      (setq x (vlax-curve-getdistatPoint ha-ename intersectpt))
	      (setq z (caddr intersectpt))
	      (setq xy (list x (* z ve)))
	      (setq
		listaxy	(append listaxy (list xy))
	      )
	    )
	  )

	  (setq	ha-ENTITY
		 (subst	(cons 38 hazvalue)
			(assoc 38 (entget (car ha)))
			(entget (car ha))
		 )
	  )
	  (entmod ha-ENTITY)
	)
      )
      (setq counter (1+ counter))
    )
  )

  (setq	listaxy
	 (vl-sort listaxy
		  (function (lambda (e1 e2)
			      (< (car e1) (car e2))
			    )
		  )
	 )
  )

  (setq	startdist (vlax-curve-getdistatPoint
		    ha-ename
		    (vlax-curve-getstartpoint ha-ename)
		  )
	enddist	  (vlax-curve-getdistatPoint
		    ha-ename
		    (vlax-curve-getendpoint ha-ename)
		  )
  )

  (setq	pt1 (car (car listaxy))
	pt2 (car (last listaxy))
  )

  (if (/= startdist pt1)
    (progn
      (setq x startdist)
      (setq y (+ (* (/ (- (cadr (car listaxy)) (cadr (cadr listaxy)))
		       (- (car (cadr listaxy)) (car (car listaxy)))
		    )
		    (- (car (car listaxy)) startdist)
		 )
		 (cadr (car listaxy))
	      )
      )
      (setq xy (list x y))
      (setq
	listaxy	(append listaxy (list xy))
      )
      (setq listaxy
	     (vl-sort listaxy
		      (function	(lambda	(e1 e2)
				  (< (car e1) (car e2))
				)
		      )
	     )
      )

    )
  )

  (if (/= enddist pt1)
    (progn
      (setq pos (1- (length listaxy)))
      (setq x enddist)
      (setq y
	     (+
	       (*
		 (/ (- (cadr (nth pos listaxy))
		       (cadr (nth (1- pos) listaxy))
		    )
		    (- (car (nth pos listaxy)) (car (nth (1- pos) listaxy)))
		 )
		 (- enddist (car (nth pos listaxy)))
	       )
	       (cadr (nth pos listaxy))
	     )
      )
      (setq xy (list x y))
      (setq
	listaxy	(append listaxy (list xy))
      )
      (setq listaxy
	     (vl-sort listaxy
		      (function	(lambda	(e1 e2)
				  (< (car e1) (car e2))
				)
		      )
	     )
      )

    )
  )
)

(defun createprofile ()
(COMMAND "_layer" "_m" "NATURAL GROUND" "_c" "94" "" "")
  (setq variante-listaxy (apply 'append listaxy))

  (setq	arraySpace
	 (vlax-make-safearray
	   vlax-vbdouble
	   (cons 0
		 (- (length variante-listaxy) 1)
	   )
	 )
  )
  (setq	variante-listaxy
	 (vlax-safearray-fill arraySpace variante-listaxy)
  )

  (vlax-make-variant variante-listaxy)


  (setq	pline (vla-addLightweightPolyline
		*ModelSpace*
		variante-listaxy
	      )
  )


  (vl-cmdf "._text"
	   (vlax-curve-getstartpoint pline)
	   "0"
	   "A"
  )
  (vl-cmdf "._text"
	   (vlax-curve-getendpoint pline)
	   "0"
	   "B"
  )
)

(defun annotate	()
  (setq	xini (car (vlax-curve-getstartpoint pline))
	xend (car (vlax-curve-getendpoint pline))
	y    (*	(fix
		  (/ (cadr (car	(vl-sort listaxy
					 (function (lambda (e1 e2)
						     (< (cadr e1) (cadr e2))
						   )
					 )
				)
			   )
		     )
		     ve
		  )
		)
		ve
	     )
  )
  ;;end setq

  (if (< y 0)
    (setq y (- y (* 1 ve)))
  )

  (setq var-xyini (apply 'append (list (list xini y 0))))
  (setq var-xyend (apply 'append (list (list xend y 0))))
  (createline)
  (COMMAND "_layer" "_m" "REFERENCE" "_c" "12" "" "")
  (setq yref (strcat "DATUM: " (rtos (/ y ve) 2 2)))
  (setq ptloc (list (- xini 30.0) y))
  (vl-cmdf "._text" ptloc "0" yref)




  (setq lengthlistaxy (length listaxy))
  (setq count 0)
  (while (< count lengthlistaxy)
    (progn
      (setq var-xyini (apply 'append
			     (list (list (car (nth count listaxy))
					 (cadr (nth count listaxy))
					 0
				   )
			     )
		      )
      )
      (setq
	var-xyend (apply 'append
			 (list (list (car (nth count listaxy)) y 0))
		  )
      )
      (createline)
      (COMMAND "_layer" "_m" "Level" "_c" "94" "" "")
      (setq ytext (rtos (/ (cadr (nth count listaxy)) ve) 2 2))
      (setq xpt (car (nth count listaxy)))
      (setq xtext (rtos xpt 2 2));;CB 11/24/09
      (setq ptloc (list xpt (- y 10.0)))
      (setq ptloc2 (list xpt (- y 30.0)));;CB 11/24/09
      (vl-cmdf "._text" ptloc "90" ytext)
      (COMMAND "_layer" "_m" "Chainage" "_c" "94" "" "")
      (vl-cmdf "._text" ptloc2 "90" xtext);;CB 11/24/09

      (setq count (1+ count))
    )
  )

)



(defun createline ()
(COMMAND "_layer" "_m" "LINE" "_c" "155" "" "")
  (setq	arraySpace
	 (vlax-make-safearray
	   vlax-vbdouble
	   (cons 0
		 (- (length var-xyini) 1)
	   )
	 )
  )
  (setq	var-xyini
	 (vlax-safearray-fill arraySpace var-xyini)
  )

  (vlax-make-variant var-xyini)

  (setq	arraySpace
	 (vlax-make-safearray
	   vlax-vbdouble
	   (cons 0
		 (- (length var-xyend) 1)
	   )
	 )
  )
  (setq	var-xyend
	 (vlax-safearray-fill arraySpace var-xyend)
  )

  (vlax-make-variant var-xyend)

  (setq	line (vla-addline
	       *ModelSpace*
	       var-xyini
	       var-xyend
	     )
  )

)


(defun c:qp ()
  (timeini)
  (inivar)
  (getlayname)
  (esttexto)
  (getha)
  (getexaggeration)
  (listptintersect)
  (createprofile)
  (annotate)
  (vl-cmdf "._zoom"
	   (vlax-curve-getstartpoint pline)
	   (vlax-curve-getendpoint pline)
  )
  (recvar)
  (timeend)
  (princ)
)

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on March 03, 2019, 11:53:32 AM

Nice update sanju2323. Can you justify the texts (Chainage and Level) to be midle center and the REFERENCE to bottom center ?

thanks

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on March 03, 2019, 02:55:21 PM

i find it.

Code - Auto/Visual Lisp: [Select]

  (vl-cmdf "._text" "_bc" ptloc "100" yref)

Code - Auto/Visual Lisp: [Select]

      (vl-cmdf "._text" "_mc" ptloc "0" ytext)
      (vl-cmdf "._text" "_mc" ptloc2 "0" xtext)
 

Thanks

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on March 17, 2019, 04:57:47 AM

Hi . I need an update to this lisp. This lisp create a quick profile from countours only and the chainage is on every countour line. I need to give me the option to load a file with chainage and elevetion and then create the profile.

For example to ask

1. profile from countours ?
2. profile ftom file ?
3. or for faster select a 3d polyline

Code - Auto/Visual Lisp: [Select]

;;;Author: Pedro Miguel da Silva Ferreira       Email:pedro_ferreira@netcabo.pt or pferreira@wsatkins.pt
;;;Web page: http:pwp.netcabo.pt/pedro_ferreira
;;;Location: Portugal, Lisboa
;;;RDS: PMSF
;;;Command Name: qp
;;;Date: 09 of May 2006
;;;Version: 1.0
;;;Description: Visual Lisp Routine that creates a section profile of the terrain based on the existing contours.
;;;Modified 11/20/09 CAB request of ttxxx of AutoLisp Forum, to print chainage info, tabular form
 
 
(defun timeini ()
  (setq s (getvar "DATE"))
  (setq seconds (* 86400.0 (- s (fix s))))
)
 
(defun timeend ()
  (setq s1 (getvar "DATE"))
  (setq seconds1 (* 86400.0 (- s1 (fix s1))))
  (setq seconds2 (fix (- seconds1 seconds)))
  (princ
    (strcat "\nTime : "
            (itoa seconds2)
            " seconds"
    )
  )
)
 
(defun inivar ()
  (setq cmd_ini (getvar "cmdecho")
        fla_ini (getvar "flatland")
        osm_ini (getvar "osmode")
        ort_ini (getvar "orthomode")
        plt_ini (getvar "plinetype")
        aup_ini (getvar "auprec")
        uni_ini (getvar "unitmode")
        lun_ini (getvar "lunits")
        diz_ini (getvar "dimzin")
        edg_ini (getvar "edgemode")
  )
  (setvar "CMDECHO" 0)
  (setvar "FLATLAND" 0)
  (setvar "OSMODE" 0)
  (setvar "ORTHOMODE" 0)
  (setvar "PLINETYPE" 2)
  (setvar "AUPREC" 0)
  (setvar "UNITMODE" 1)
  (setvar "LUNITS" 2)
  (setvar "DIMZIN" 0)
  (setvar "EDGEMODE" 1)
)
 
(defun recvar ()
  (setvar "CMDECHO" cmd_ini)
  (setvar "FLATLAND" fla_ini)
  (setvar "OSMODE" osm_ini)
  (setvar "ORTHOMODE" ort_ini)
  (setvar "PLINETYPE" plt_ini)
  (setvar "AUPREC" aup_ini)
  (setvar "UNITMODE" uni_ini)
  (setvar "LUNITS" lun_ini)
  (setvar "DIMZIN" diz_ini)
  (setvar "EDGEMODE" edg_ini)
)
 
;; Unique  -  Lee Mac
;; Returns a list with duplicate elements removed.
(defun LM:Unique (l / x r)
  (while l
    (setq x (car l)
          l (vl-remove x (cdr l))
          r (cons x r)
    )
  )
  (reverse r)
)
 
(defun getlayname (/ selset lyrset n ent)
  (setq contourstest nil)
  (while (= contourstest nil)
    (prompt "\nSelect one or more entities to get Contours Layer(s) : ")
    (setq selset (ssget "_X" (list (cons 0 "*LINE")))) ;(setq selset (ssget "_:L" '((0 . "*LINE"))))
    (setq lyrset (list))
    (repeat (setq n (sslength selset))
      (setq ent (ssname selset (setq n (1- n))))
      (setq lyrset (append lyrset (list (vla-get-layer (vlax-ename->vla-object ent)))))
    )
    (setq lyrset (LM:Unique lyrset))
    (setq contourstest
           (ssget "_X"
                  (append '((0 . "*LINE") (-4 . "<OR")) (mapcar '(lambda (n) (cons 8 n)) lyrset) '((-4 . "OR>")))
           )
    )
  )
)
 
(defun activexsupport ()
  (vl-load-com)
  (setq *modelspace*
         (vla-get-modelspace
           (vla-get-activedocument (vlax-get-acad-object))
         )
  )
)
 
(defun esttexto ()
 
  (vl-cmdf "._style" "PMSF-TEXT" "romans" 2.50 0.80 0 "n" "n" "n")
)
 
(defun getha ()
  ;; this entity must be a lwpolyline
  (activexsupport)
  (setq
    ha (entsel "\nSelect the Horizontal alignment: ")
  )
  (while (= ha nil)
    (progn
      (princ "\nNothing selected...")
      (setq ha
             (entsel "\nSelect the Horizontal alignment: ")
      )
    )
  )
  (setq ha-type (cdr (assoc 0 (entget (car ha)))))
  (if (not (equal ha-type "LWPOLYLINE"))
    (progn
      (setq ha nil)
      (princ "\n***Horizontal Alignment must be a LWPolyline***")
    )
  )
  (while (= ha nil)
    (progn
      (princ "\nNothing selected...")
      (setq ha
             (entsel "\nSelect the Horizontal alignment: ")
      )
      (setq ha-type (cdr (assoc 0 (entget (car ha)))))
      (if (not (equal ha-type "LWPOLYLINE"))
        (progn
          (setq ha nil)
          (princ "\n***Horizontal Alignment must be a LWPolyline***")
        )
      )
    )
  )
  (setq ha-ename (entget (car ha)))
  (setq ha-ename (cdr (assoc -1 ha-ename)))
  (setq ha-object (vlax-ename->vla-object ha-ename))
 
  (vl-cmdf "._text"
           (vlax-curve-getstartpoint ha-object)
           "0"
           "A"
  )
  (vl-cmdf "._text"
           (vlax-curve-getendpoint ha-object)
           "0"
           "B"
  )
)
 
(defun getexaggeration ()
  (initget 2)
  (setq ve (getreal "\nEnter the vertical exaggeration <1>: "))
  (if (= ve nil)
    (setq ve 1)
  )
)
 
 
(defun listptintersect ()
  (setq listaxy nil)
 
  (setq hazvalue (caddr (vlax-curve-getStartPoint ha-object)))
 
  (setq curvas contourstest)
  (setq ncurvas (sslength curvas))
  (setq listaxy nil)
  (setq counter 0)
  (while (< counter ncurvas)
    (progn
      (setq cnivel-ename (ssname curvas counter))
      (setq cnivel-object (vlax-ename->vla-object cnivel-ename))
 
      (setq cnivelzvalue
             (caddr (vlax-curve-getStartPoint cnivel-object))
      )
 
      (setq ha-ENTITY
             (subst (cons 38 cnivelzvalue)
                    (assoc 38 (entget (car ha)))
                    (entget (car ha))
             )
      )
      (entmod ha-ENTITY)
 
      (setq intersectpt
             (vlax-variant-value
               (vlax-invoke-method
                 ha-object
                 "IntersectWith"
                 cnivel-object
                 acExtendNone
               )
             )
      )
 
      (setq test nil)
      (setq
        test (vl-catch-all-apply
               'vlax-safearray->list
               (list intersectpt)
             )
      )
      (setq error (vl-catch-all-error-p test))
 
      (if (/= error t)
        (progn
          (setq intersectpt (vlax-safearray->list intersectpt))
          (setq interlength (length intersectpt))
 
          (if (> interlength 3)
            (progn
              (setq dividelength (/ interlength 3))
              (setq count 0)
              (while (< count interlength)
                (progn
                  (setq newpt (list (nth count intersectpt)
                                    (nth (+ count 1) intersectpt)
                                    (nth (+ count 2) intersectpt)
                              )
                  )
 
                  (setq x (vlax-curve-getdistatPoint ha-ename newpt))
                  (setq z (caddr intersectpt))
                  (setq xy (list x (* z ve)))
                  (setq
                    listaxy (append listaxy (list xy))
                  )
 
                  (setq count (+ count 3))
                )
              )
            )
            (progn
              (setq x (vlax-curve-getdistatPoint ha-ename intersectpt))
              (setq z (caddr intersectpt))
              (setq xy (list x (* z ve)))
              (setq
                listaxy (append listaxy (list xy))
              )
            )
          )
 
          (setq ha-ENTITY
                 (subst (cons 38 hazvalue)
                        (assoc 38 (entget (car ha)))
                        (entget (car ha))
                 )
          )
          (entmod ha-ENTITY)
        )
      )
      (setq counter (1+ counter))
    )
  )
 
  (setq listaxy
         (vl-sort listaxy
                  (function (lambda (e1 e2)
                              (< (car e1) (car e2))
                            )
                  )
         )
  )
 
  (setq startdist (vlax-curve-getdistatPoint
                    ha-ename
                    (vlax-curve-getstartpoint ha-ename)
                  )
        enddist   (vlax-curve-getdistatPoint
                    ha-ename
                    (vlax-curve-getendpoint ha-ename)
                  )
  )
 
  (setq pt1 (car (car listaxy))
        pt2 (car (last listaxy))
  )
 
  (if (/= startdist pt1)
    (progn
      (setq x startdist)
      (setq y (+ (* (/ (- (cadr (car listaxy)) (cadr (cadr listaxy)))
                       (- (car (cadr listaxy)) (car (car listaxy)))
                    )
                    (- (car (car listaxy)) startdist)
                 )
                 (cadr (car listaxy))
              )
      )
      (setq xy (list x y))
      (setq
        listaxy (append listaxy (list xy))
      )
      (setq listaxy
             (vl-sort listaxy
                      (function (lambda (e1 e2)
                                  (< (car e1) (car e2))
                                )
                      )
             )
      )
 
    )
  )
 
  (if (/= enddist pt1)
    (progn
      (setq pos (1- (length listaxy)))
      (setq x enddist)
      (setq y
             (+
               (*
                 (/ (- (cadr (nth pos listaxy))
                       (cadr (nth (1- pos) listaxy))
                    )
                    (- (car (nth pos listaxy)) (car (nth (1- pos) listaxy)))
                 )
                 (- enddist (car (nth pos listaxy)))
               )
               (cadr (nth pos listaxy))
             )
      )
      (setq xy (list x y))
      (setq
        listaxy (append listaxy (list xy))
      )
      (setq listaxy
             (vl-sort listaxy
                      (function (lambda (e1 e2)
                                  (< (car e1) (car e2))
                                )
                      )
             )
      )
 
    )
  )
)
 
(defun createprofile ()
(COMMAND "_layer" "_m" "NATURAL GROUND" "_c" "94" "" "")
  (setq variante-listaxy (apply 'append listaxy))
 
  (setq arraySpace
         (vlax-make-safearray
           vlax-vbdouble
           (cons 0
                 (- (length variante-listaxy) 1)
           )
         )
  )
  (setq variante-listaxy
         (vlax-safearray-fill arraySpace variante-listaxy)
  )
 
  (vlax-make-variant variante-listaxy)
 
 
  (setq pline (vla-addLightweightPolyline
                *ModelSpace*
                variante-listaxy
              )
  )
 
 
  (vl-cmdf "._text"
           (vlax-curve-getstartpoint pline)
           "0"
           "A"
  )
  (vl-cmdf "._text"
           (vlax-curve-getendpoint pline)
           "0"
           "B"
  )
)
 
(defun annotate ()
  (setq xini (car (vlax-curve-getstartpoint pline))
        xend (car (vlax-curve-getendpoint pline))
        y    (* (fix
                  (/ (cadr (car (vl-sort listaxy
                                         (function (lambda (e1 e2)
                                                     (< (cadr e1) (cadr e2))
                                                   )
                                         )
                                )
                           )
                     )
                     ve
                  )
                )
                ve
             )
  )
  ;;end setq
 
  (if (< y 0)
    (setq y (- y (* 1 ve)))
  )
 
  (setq var-xyini (apply 'append (list (list xini y 0))))
  (setq var-xyend (apply 'append (list (list xend y 0))))
  (createline)
  (COMMAND "_layer" "_m" "REFERENCE" "_c" "12" "" "")
  (setq yref (strcat "DATUM: " (rtos (/ y ve) 2 2)))
  (setq ptloc (list (- xini 30.0) y))
  (vl-cmdf "._text" "_bc" ptloc "100" yref)
 
 
 
 
  (setq lengthlistaxy (length listaxy))
  (setq count 0)
  (while (< count lengthlistaxy)
    (progn
      (setq var-xyini (apply 'append
                             (list (list (car (nth count listaxy))
                                         (cadr (nth count listaxy))
                                         0
                                   )
                             )
                      )
      )
      (setq
        var-xyend (apply 'append
                         (list (list (car (nth count listaxy)) y 0))
                  )
      )
      (createline)
      (COMMAND "_layer" "_m" "Level" "_c" "94" "" "")
      (setq ytext (rtos (/ (cadr (nth count listaxy)) ve) 2 2))
      (setq xpt (car (nth count listaxy)))
      (setq xtext (rtos xpt 2 2));;CB 11/24/09
      (setq ptloc (list xpt (- y 10.0)))
      (setq ptloc2 (list xpt (- y 30.0)));;CB 11/24/09
      (vl-cmdf "._text" "_mc" ptloc "0" ytext)
      (COMMAND "_layer" "_m" "Chainage" "_c" "94" "" "")
      (vl-cmdf "._text" "_mc" ptloc2 "0" xtext);;CB 11/24/09
 
      (setq count (1+ count))
    )
  )
 
)
 
 
 
(defun createline ()
(COMMAND "_layer" "_m" "LINE" "_c" "155" "" "")
  (setq arraySpace
         (vlax-make-safearray
           vlax-vbdouble
           (cons 0
                 (- (length var-xyini) 1)
           )
         )
  )
  (setq var-xyini
         (vlax-safearray-fill arraySpace var-xyini)
  )
 
  (vlax-make-variant var-xyini)
 
  (setq arraySpace
         (vlax-make-safearray
           vlax-vbdouble
           (cons 0
                 (- (length var-xyend) 1)
           )
         )
  )
  (setq var-xyend
         (vlax-safearray-fill arraySpace var-xyend)
  )
 
  (vlax-make-variant var-xyend)
 
  (setq line (vla-addline
               *ModelSpace*
               var-xyini
               var-xyend
             )
  )
 
)
 
 
(defun c:qp ()
  (timeini)
  (inivar)
  (getlayname)
  (esttexto)
  (getha)
  (getexaggeration)
  (listptintersect)
  (createprofile)
  (annotate)
  (vl-cmdf "._zoom"
           (vlax-curve-getstartpoint pline)
           (vlax-curve-getendpoint pline)
  )
  (recvar)
  (timeend)
  (princ)
)
 

Thanks

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on March 30, 2019, 01:15:14 PM

Hi . I need to do some changes to this code. Delete everything about contours.

1) select ground polyline
2) Enter the vertical exaggeration <1>
3) Enter the Referense
4)Keep the layer names
(COMMAND "_layer" "_m" "REFERENCE" "_c" "7" "" "")
(COMMAND "_layer" "_m" "ELEVETIONS" "_c" "7" "" "")
(COMMAND "_layer" "_m" "DISTANSE" "_c" "7" "" "")

If it posible it will be usefull to have an optrion to support a second ground polyline like

Code - Auto/Visual Lisp: [Select]

(progn
           (initget "1 2")
           (setq
             l
              (cond
                ((getkword
                   "\nGround 1 (1)/ Ground 2 (2) < 1 > :"
                 )
                )
                ("1")
              )
           )
 
(if (eq l "1")
        (COMMAND "_layer" "_m" "Ground1" "_c" "94" "" "")
       )
       (if (eq l "2")
        (COMMAND "_layer" "_m" "Ground2" "_c" "10" "" "")
           )
)
 

The code i use is

Code - Auto/Visual Lisp: [Select]

;;; CADALYST 09/06  Tip 2149: QuickProfile.lsp  Center Line Profile     (c) 2006 Pedro Ferreira 
 
 
;;;Author: Pedro Miguel da Silva Ferreira       Email:pedro_ferreira@netcabo.pt or pferreira@wsatkins.pt
;;;Web page: http:pwp.netcabo.pt/pedro_ferreira
;;;Location: Portugal, Lisboa
;;;RDS: PMSF
;;;Command Name: qp
;;;Date: 09 of May 2006
;;;Version: 1.0
;;;Description: Visual Lisp Routine that creates a section profile of the terrain based on the existing contours.
;;;&#913;&#925;&#913;&#914;&#913;&#920;&#924;&#919;&#931;&#919; 3 &#924;&#913;&#929;&#932;&#921;&#927;&#933; 2019
;;;Version: 2.0 
;;;TopoCAD 
 
(defun timeini ()
  (setq s (getvar "DATE"))
  (setq seconds (* 86400.0 (- s (fix s))))
)
 
(defun timeend ()
  (setq s1 (getvar "DATE"))
  (setq seconds1 (* 86400.0 (- s1 (fix s1))))
  (setq seconds2 (fix (- seconds1 seconds)))
  (princ
    (strcat "\nTime : "
            (itoa seconds2)
            " seconds"
    )
  )
)
 
(defun inivar ()
  (setq cmd_ini (getvar "cmdecho")
        fla_ini (getvar "flatland")
        osm_ini (getvar "osmode")
        ort_ini (getvar "orthomode")
        plt_ini (getvar "plinetype")
        aup_ini (getvar "auprec")
        uni_ini (getvar "unitmode")
        lun_ini (getvar "lunits")
        diz_ini (getvar "dimzin")
        edg_ini (getvar "edgemode")
  )
  (setvar "CMDECHO" 0)
  (setvar "FLATLAND" 0)
  (setvar "OSMODE" 0)
  (setvar "ORTHOMODE" 0)
  (setvar "PLINETYPE" 2)
  (setvar "AUPREC" 0)
  (setvar "UNITMODE" 1)
  (setvar "LUNITS" 2)
  (setvar "DIMZIN" 0)
  (setvar "EDGEMODE" 1)
)
 
(defun recvar ()
  (setvar "CMDECHO" cmd_ini)
  (setvar "FLATLAND" fla_ini)
  (setvar "OSMODE" osm_ini)
  (setvar "ORTHOMODE" ort_ini)
  (setvar "PLINETYPE" plt_ini)
  (setvar "AUPREC" aup_ini)
  (setvar "UNITMODE" uni_ini)
  (setvar "LUNITS" lun_ini)
  (setvar "DIMZIN" diz_ini)
  (setvar "EDGEMODE" edg_ini)
)
 
(defun getlayname ()
  (setq contourstest nil)
;  (setq        layername
;        (getstring
;          "\nPlease enter the layer name of the contours: "
;        )
;  )
  (setq contourstest
         (ssget "_x"
                (list (cons -4 "<OR")
                      (cons -4 "<AND")
                      (cons 0 "lwpolyline")
                      (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
                      (cons -4 "AND>")
                      (cons -4 "<AND")
                      (cons 0 "polyline")
                      (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
                      (cons -4 "AND>")
                      (cons -4 "<AND")
                      (cons 0 "line")
                      (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
                      (cons -4 "AND>")
                      (cons -4 "<AND")
                      (cons 0 "spline")
                      (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
                      (cons -4 "AND>")
                      (cons -4 "OR>")
                )
         )
  )
 
  (while (= contourstest nil)
    (princ "\n&#916;&#949;&#957; &#949;&#960;&#953;&#955;&#941;&#967;&#952;&#951;&#954;&#945;&#957; &#953;&#963;&#959;&#965;&#968;&#949;&#943;&#962;...")
;    (setq layername
;          (getstring
;            "\nPlease enter the layer name of the contours: "
;          )
;    )
    (setq contourstest
           (ssget "_x"
                  (list (cons -4 "<OR")
                        (cons -4 "<AND")
                        (cons 0 "lwpolyline")
                        (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
                        (cons -4 "AND>")
                        (cons -4 "<AND")
                        (cons 0 "polyline")
                        (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
                        (cons -4 "AND>")
                        (cons -4 "<AND")
                        (cons 0 "line")
                        (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
                        (cons -4 "AND>")
                        (cons -4 "<AND")
                        (cons 0 "spline")
                        (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
                        (cons -4 "AND>")
                        (cons -4 "OR>")
                  )
           )
    )
  )
)
 
(defun activexsupport ()
  (vl-load-com)
  (setq *modelspace*
         (vla-get-modelspace
           (vla-get-activedocument (vlax-get-acad-object))
         )
  )
)
 
(defun esttexto ()
 
  (vl-cmdf "._style" "PMSF-TEXT" "Arial" 1.8 1 0 "n" "n" "n")
)
 
(defun getha ()
  ;; this entity must be a lwpolyline
  (activexsupport)
  (setq
    ha (entsel "\n&#917;&#960;&#953;&#955;&#941;&#958;&#964;&#949; &#964;&#959;&#957; &#940;&#958;&#959;&#957;&#945; &#964;&#951;&#962; &#964;&#959;&#956;&#942;&#962;: ")
  )
  (while (= ha nil)
    (progn
      (princ "\n&#916;&#949;&#957; &#949;&#960;&#953;&#955;&#941;&#967;&#952;&#951;&#954;&#949; &#940;&#958;&#959;&#957;&#945;&#962;...")
      (setq ha
             (entsel "\n&#917;&#960;&#953;&#955;&#941;&#958;&#964;&#949; &#964;&#959;&#957; &#940;&#958;&#959;&#957;&#945; &#964;&#951;&#962; &#964;&#959;&#956;&#942;&#962;: ")
      )
    )
  )
  (setq ha-type (cdr (assoc 0 (entget (car ha)))))
  (if (not (equal ha-type "LWPOLYLINE"))
    (progn
      (setq ha nil)
      (princ "\n***&#927; &#940;&#958;&#959;&#957;&#945;&#962; &#964;&#951;&#962; &#964;&#959;&#956;&#942;&#962; &#960;&#961;&#941;&#960;&#949;&#953; &#957;&#945; &#949;&#943;&#957;&#945;&#953; LWPolyline***")
    )
  )
  (while (= ha nil)
    (progn
      (princ "\n&#916;&#949;&#957; &#949;&#960;&#953;&#955;&#941;&#967;&#952;&#951;&#954;&#949; &#940;&#958;&#959;&#957;&#945;&#962;...")
      (setq ha
             (entsel "\n&#917;&#960;&#953;&#955;&#941;&#958;&#964;&#949; &#964;&#959;&#957; &#940;&#958;&#959;&#957;&#945; &#964;&#951;&#962; &#964;&#959;&#956;&#942;&#962;: ")
      )
      (setq ha-type (cdr (assoc 0 (entget (car ha)))))
      (if (not (equal ha-type "LWPOLYLINE"))
        (progn
          (setq ha nil)
          (princ "\n***&#927; &#940;&#958;&#959;&#957;&#945;&#962; &#964;&#951;&#962; &#964;&#959;&#956;&#942;&#962; &#960;&#961;&#941;&#960;&#949;&#953; &#957;&#945; &#949;&#943;&#957;&#945;&#953; LWPolyline***")
        )
      )
    )
  )
  (setq ha-ename (entget (car ha)))
  (setq ha-ename (cdr (assoc -1 ha-ename)))
  (setq ha-object (vlax-ename->vla-object ha-ename))
 
  (vl-cmdf "._text"
           (vlax-curve-getstartpoint ha-object)
           "100" ; 
           "A"
  )
  (vl-cmdf "._text"
           (vlax-curve-getendpoint ha-object)
           "100" ; 
           "B"
  )
)
 
(defun getexaggeration ()
  (initget 2)
  (setq ve (getreal "\n Enter the vertical exaggeration <1>: "))
  (if (= ve nil)
    (setq ve 1)
  )
)
 
 
(defun listptintersect ()
  (setq listaxy nil)
 
  (setq hazvalue (caddr (vlax-curve-getStartPoint ha-object)))
 
  (setq curvas contourstest)
  (setq ncurvas (sslength curvas))
  (setq listaxy nil)
  (setq counter 0)
  (while (< counter ncurvas)
    (progn
      (setq cnivel-ename (ssname curvas counter))
      (setq cnivel-object (vlax-ename->vla-object cnivel-ename))
 
      (setq cnivelzvalue
             (caddr (vlax-curve-getStartPoint cnivel-object))
      )
 
      (setq ha-ENTITY
             (subst (cons 38 cnivelzvalue)
                    (assoc 38 (entget (car ha)))
                    (entget (car ha))
             )
      )
      (entmod ha-ENTITY)
 
      (setq intersectpt
             (vlax-variant-value
               (vlax-invoke-method
                 ha-object
                 "IntersectWith"
                 cnivel-object
                 acExtendNone
               )
             )
      )
 
      (setq test nil)
      (setq
        test (vl-catch-all-apply
               'vlax-safearray->list
               (list intersectpt)
             )
      )
      (setq error (vl-catch-all-error-p test))
 
      (if (/= error t)
        (progn
          (setq intersectpt (vlax-safearray->list intersectpt))
          (setq interlength (length intersectpt))
 
          (if (> interlength 3)
            (progn
              (setq dividelength (/ interlength 3))
              (setq count 0)
              (while (< count interlength)
                (progn
                  (setq newpt (list (nth count intersectpt)
                                    (nth (+ count 1) intersectpt)
                                    (nth (+ count 2) intersectpt)
                              )
                  )
 
                  (setq x (vlax-curve-getdistatPoint ha-ename newpt))
                  (setq z (caddr intersectpt))
                  (setq xy (list x (* z ve)))
                  (setq
                    listaxy (append listaxy (list xy))
                  )
 
                  (setq count (+ count 3))
                )
              )
            )
            (progn
              (setq x (vlax-curve-getdistatPoint ha-ename intersectpt))
              (setq z (caddr intersectpt))
              (setq xy (list x (* z ve)))
              (setq
                listaxy (append listaxy (list xy))
              )
            )
          )
 
          (setq ha-ENTITY
                 (subst (cons 38 hazvalue)
                        (assoc 38 (entget (car ha)))
                        (entget (car ha))
                 )
          )
          (entmod ha-ENTITY)
        )
      )
      (setq counter (1+ counter))
    )
  )
 
  (setq listaxy
         (vl-sort listaxy
                  (function (lambda (e1 e2)
                              (< (car e1) (car e2))
                            )
                  )
         )
  )
 
  (setq startdist (vlax-curve-getdistatPoint
                    ha-ename
                    (vlax-curve-getstartpoint ha-ename)
                  )
        enddist   (vlax-curve-getdistatPoint
                    ha-ename
                    (vlax-curve-getendpoint ha-ename)
                  )
  )
 
  (setq pt1 (car (car listaxy))
        pt2 (car (last listaxy))
  )
 
  (if (/= startdist pt1)
    (progn
      (setq x startdist)
      (setq y (+ (* (/ (- (cadr (car listaxy)) (cadr (cadr listaxy)))
                       (- (car (cadr listaxy)) (car (car listaxy)))
                    )
                    (- (car (car listaxy)) startdist)
                 )
                 (cadr (car listaxy))
              )
      )
      (setq xy (list x y))
      (setq
        listaxy (append listaxy (list xy))
      )
      (setq listaxy
             (vl-sort listaxy
                      (function (lambda (e1 e2)
                                  (< (car e1) (car e2))
                                )
                      )
             )
      )
 
    )
  )
 
  (if (/= enddist pt1)
    (progn
      (setq pos (1- (length listaxy)))
      (setq x enddist)
      (setq y
             (+
               (*
                 (/ (- (cadr (nth pos listaxy))
                       (cadr (nth (1- pos) listaxy))
                    )
                    (- (car (nth pos listaxy)) (car (nth (1- pos) listaxy)))
                 )
                 (- enddist (car (nth pos listaxy)))
               )
               (cadr (nth pos listaxy))
             )
      )
      (setq xy (list x y))
      (setq
        listaxy (append listaxy (list xy))
      )
      (setq listaxy
             (vl-sort listaxy
                      (function (lambda (e1 e2)
                                  (< (car e1) (car e2))
                                )
                      )
             )
      )
 
    )
  )
)
 
(defun createprofile ()
(COMMAND "_layer" "_m" "NATURAL GROUND" "_c" "94" "" "")
  (setq variante-listaxy (apply 'append listaxy))
 
  (setq arraySpace
         (vlax-make-safearray
           vlax-vbdouble
           (cons 0
                 (- (length variante-listaxy) 1)
           )
         )
  )
  (setq variante-listaxy
         (vlax-safearray-fill arraySpace variante-listaxy)
  )
 
  (vlax-make-variant variante-listaxy)
 
 
  (setq pline (vla-addLightweightPolyline
                *ModelSpace*
                variante-listaxy
              )
  )
 
 
  (vl-cmdf "._text"
           (vlax-curve-getstartpoint pline)
           "100" ; &#915;&#937;&#925;&#906;&#913; &#928;&#917;&#929;&#921;&#931;&#932;&#929;&#927;&#934;&#919;&#931; &#922;&#917;&#921;&#924;&#917;&#925;&#927;&#933; 100
           "A"
  )
  (vl-cmdf "._text"
           (vlax-curve-getendpoint pline)
           "100" ; &#915;&#937;&#925;&#906;&#913; &#928;&#917;&#929;&#921;&#931;&#932;&#929;&#927;&#934;&#919;&#931; &#922;&#917;&#921;&#924;&#917;&#925;&#927;&#933; 100
           "B"
  )
)
 
(defun annotate ()
  (setq xini (car (vlax-curve-getstartpoint pline))
        xend (car (vlax-curve-getendpoint pline))
        y    (* (fix
                  (/ (cadr (car (vl-sort listaxy
                                         (function (lambda (e1 e2)
                                                     (< (cadr e1) (cadr e2))
                                                   )
                                         )
                                )
                           )
                     )
                     ve
                  )
                )
                ve
             )
  )
  ;;end setq
 
  (if (< y 0)
    (setq y (- y (* 1 ve)))
  )
 
  (setq var-xyini (apply 'append (list (list xini y 0))))
  (setq var-xyend (apply 'append (list (list xend y 0))))
  (createline)
  (COMMAND "_layer" "_m" "REFERENCE" "_c" "7" "" "")
  (setq yref (strcat "H = " (rtos (/ y ve) 2 2) " m"))
  (setq ptloc (list (- xini 30.0) y))
  (vl-cmdf "._text" "_bc" ptloc "100" yref)
 
 
 
 
  (setq lengthlistaxy (length listaxy))
  (setq count 0)
  (while (< count lengthlistaxy)
    (progn
      (setq var-xyini (apply 'append
                             (list (list (car (nth count listaxy))
                                         (cadr (nth count listaxy))
                                         0
                                   )
                             )
                      )
      )
      (setq
        var-xyend (apply 'append
                         (list (list (car (nth count listaxy)) y 0))
                  )
      )
      (createline)
      (COMMAND "_layer" "_m" "elevetion" "_c" "7" "" "")
      (setq ytext (rtos (/ (cadr (nth count listaxy)) ve) 2 2))
      (setq xpt (car (nth count listaxy)))
      (setq xtext (rtos xpt 2 2))  ;CB 11/24/09
      (setq ptloc (list xpt (- y 6.0)))
      (setq ptloc2 (list xpt (- y 54.0))) ;CB 11/24/09
      (vl-cmdf "._text" "_mc" ptloc "0" ytext) 
      (COMMAND "_layer" "_m" "DISTANSE" "_c" "7" "" "")
      (vl-cmdf "._text" "_mc" ptloc2 "0" xtext) ;CB 11/24/09 
      (setq count (1+ count))
    )
  )
 
 
 
 
)
 
 
 
 
 
(defun createline ()
(COMMAND "_layer" "_m" "lines" "_c" "7" "" "")
  (setq arraySpace
         (vlax-make-safearray
           vlax-vbdouble
           (cons 0
                 (- (length var-xyini) 1)
           )
         )
  )
  (setq var-xyini
         (vlax-safearray-fill arraySpace var-xyini)
  )
 
  (vlax-make-variant var-xyini)
 
  (setq arraySpace
         (vlax-make-safearray
           vlax-vbdouble
           (cons 0
                 (- (length var-xyend) 1)
           )
         )
  )
  (setq var-xyend
         (vlax-safearray-fill arraySpace var-xyend)
  )
 
  (vlax-make-variant var-xyend)
 
  (setq line (vla-addline
               *ModelSpace*
               var-xyini
               var-xyend
             )
  )
 
)
 
 
 
 
(defun c:qp ()
 
  (timeini)
  (inivar)
  (getlayname)
  (esttexto)
  (getha)
  (getexaggeration)
  (listptintersect)
  (createprofile)
  (annotate)
 
  (vl-cmdf "._zoom"
           (vlax-curve-getstartpoint pline)
           (vlax-curve-getendpoint pline)
  )
  (recvar)
  (timeend)
 
 
 (command "setvar" "clayer" "0")
  (princ)
)
 
 

Thanks

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on March 31, 2019, 03:10:45 PM

I use this lisp code to draw the section from a txt file, but i need an update.
1) Enter the Referense and the vertical exaggeration <1>
2) write the elevetion and distanse text like the previous lisp in the same distanses
3) if i choose ground 2 i want an option
a) from exist polyline
b)or from txt file
and then write the elevetion and distanse text under the ground one text

Code - Auto/Visual Lisp: [Select]

(Defun c:test()
(setvar "OSMODE" 0)
(progn
           (initget "1 2")
           (setq
             l
              (cond
                ((getkword
                   "\nground1 (1)/ &#915;&#953;&#945; ground2 (2) < 1 > :"
                 )
                )
                ("1")
              )
           )
 
(if (eq l "1")
        (COMMAND "_layer" "_m" "ground1" "_c" "94" "" "")
       )
       (if (eq l "2")
        (COMMAND "_layer" "_m" "ground2" "_c" "10" "" "")
           )
)
(setq FH (getfiled "select file  L,H (*.txt)" "" "txt" 16))
(setq fil (open FH "r"))
(command "_.pline"); start Polyline
(while (setq lin (read-line fil)) (command lin)); feed in coordinates
(command ""); end Polyline
(setvar "OSMODE" 77)
(command "zoom" "e")
(close fil)
);End Defun
 

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on April 01, 2019, 04:58:47 PM

no one ? :-(

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: snownut2 on April 01, 2019, 07:42:58 PM

Looks to me like your looking for a lisp to do road Center-Line design. The one you currently use doesn't come anywhere near that level of functionality. What you need is one (function) that would use the cross section generated by the lisp you now use to perform the additional task off the "PROPOSED" center-line. There is only one line that lies on the ground "EXISTING GRADE". It is very unclear just what this text file is you refer to, if your looking to draw a line based on coordinates in a text/csv file you can do that with a simple "Entmake" function, just feed it the point list.

Also looks like your looking to do stationing, existing elevation, proposed elevation including PT's, road grades and VC info.

Please give a full description of what your looking for, and not take the "leading the horse around by the nose" approach.

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on April 02, 2019, 01:16:09 AM

The test.lsp draws polyline from file. The test.txt file contain the chainage and the elevetion. But the elevetions is allready ( elevetion * 10) because the vertical exaggeration must be 10.
In the last version of qp.lsp when we select the center line and the contours the lisp draws the ground line with the chainage and the elevetion.

The vertical exaggeration is important because some times must be 1 .

The problem is that i dont have contours any time and i need to draw a Center-Line profile from a file like test.txt. And some times i need to add a second ground from file or to draw the second ground and print the elevetion and chainage (without 0+ ...... (for example 0 + 250) , only the numbe (for example 250))

if it helps i use test table.dwg under the ground lines

Thanks

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on April 03, 2019, 01:59:38 AM

I find an old code . This code works but i need to to add a vertical exaggeration like the quick profile lisp because the most times the evetions will be (elev * 10) so when write the text of the elevetion must be (elev / 10)

Code - Auto/Visual Lisp: [Select]

(defun ERR (S)
  (if (= S "Function cancelled")
    (princ "\nVERTEXT - cancelled: ")
    (progn (princ "\nVERTEXT - Error: ") (princ S) (terpri))
  )
  (RESETTING)
  (princ "SYSTEM VARIABLES have been reset\n")
  (princ)
)
(defun SETV (SYSTVAR NEWVAL)
  (setq X (read (strcat SYSTVAR "1")))
  (set X (getvar SYSTVAR))
  (setvar SYSTVAR NEWVAL)
)
(defun SETTING ()
  (setq OERR *ERROR*)
  (setq *ERROR* ERR)
  (SETV "CMDECHO" 0)
  (SETV "BLIPMODE" 0)
)
(defun RSETV (SYSTVAR)
  (setq X (read (strcat SYSTVAR "1")))
  (setvar SYSTVAR (eval X))
)
 
(defun RESETTING ()
  (RSETV "CMDECHO")
  (RSETV "BLIPMODE")
  (setq *ERROR* OERR)
)
 
 
(defun DXF (CODE ENAME) (cdr (assoc CODE (entget ENAME)))) ; dxf
 
(defun VERTEXT (/ EN VLIST)
  (setq EN (GET-EN))
  (if (= (DXF 0 EN) "LWPOLYLINE")
    (setq VLIST (GET-LWVLIST EN))
    (setq VLIST (GET-PLVLIST EN))
  )
  (WRITE-IT VLIST EN)
)
 
(defun GET-EN (/ NO-ENT EN MSG1 MSG2)
  (setq NO-ENT 1
        EN     NIL
        MSG1   "\nselect polyline: "
        MSG2   "\nthis is not a polyline !!!."
  )                                     ; setq
  (while NO-ENT
    (setq EN (car (entsel MSG1)))
    (if (and EN
             (or (= (DXF 0 EN) "LWPOLYLINE") (= (DXF 0 EN) "POLYLINE"))
                                        ; or
        )                               ; and
      (progn (setq NO-ENT NIL))         ; progn
      (prompt MSG2)
    )                                   ; if
  )                                     ; while
  EN
)                                       ; get-en
 
(defun GET-LWVLIST (EN / ELIST NUM-VERT VLIST)
  (setq ELIST    (entget EN)
        NUM-VERT (cdr (assoc 90 ELIST))
        ELIST    (member (assoc 10 ELIST) ELIST)
        VLIST    NIL
  )                                     ; setq
  (repeat NUM-VERT
    (setq VLIST (append VLIST (list (cdr (assoc 10 ELIST)))) ; append
    )                                   ; setq
    (setq ELIST (cdr ELIST)
          ELIST (member (assoc 10 ELIST) ELIST)
    )                                   ; setq
  )                                     ; repeat
  VLIST
)                                       ; get-lwvlist
 
(defun GET-PLVLIST (EN / VLIST)
  (setq VLIST NIL
        EN    (entnext EN)
  )                                     ; setq
  (while (/= "SEQEND" (DXF 0 EN))
    (setq VLIST (append VLIST (list (DXF 10 EN))))
    (setq EN (entnext EN))
  )                                     ; while
  VLIST
)                                       ; get-plvlist
 
(defun WRITE-IT (VLST EN / NEWVLIST MSG3 FNAME)
  (setq NEWVLIST (mapcar '(lambda (X) (trans X EN 0)) ;_ lambda
                         VLST
                 ) ;_ mapcar
        MSG3     "Polyline vertex file"
                                        ;FNAME    (getfiled MSG3 "" "txt" 1)
        F1       (open "FNAME" "w")
  )                                     ; setq
  (WRITE-HEADER)
  (WRITE-VERTICES NEWVLIST)
  (setq F1 (close F1))
) ;_ write-it
 
(defun WRITE-HEADER (/ STR)
  (setq STR "        POLYLINE VERTEX POINTS")
  (write-line STR F1)
  (setq STR (strcat "  X            " "  Y            " "  Z") ;_ strcat
  ) ;_ setq
  (write-line STR F1)
) ;_ write-header
 
 
 
(defun WRITE-VERTICES (NEWVLIST / XSTR YSTR ZSTR STR l)
   (setvar 'OSMODE  0)
(progn
           (initget "1 2")
           (setq
             l
              (cond
                ((getkword
                   "\nfor Ground 1 (1)/ for ground 2 (2) < 1 > :"
                 )
                )
                ("1")
              )
           )
       
(if (eq l "1")
        (COMMAND "_layer" "_m" "ground1" "_c" "94" "" "")
       )
       (if (eq l "2")
        (COMMAND "_layer" "_m" "ground2" "_c" "10" "" "")
           )
)
  (setq httt "2")
  (setq gptx (getpoint "\nPick a point to insert length text: "))
  (setq gpty (getpoint "\nPick a point to insert elevetion text: "))
  (foreach ITEM NEWVLIST
    (setq XSTR (rtos (nth 0 (/ ITEM ve)) 2 2)
          YSTR (rtos (nth 1 ITEM) 2 2)
          ZSTR (rtos (nth 2 ITEM) 2 2)
          STR  (strcat XSTR (SPACES XSTR) YSTR (SPACES YSTR) ZSTR) ;_ strcat
    )                                   ; setq
                                        ;      (write-line STR F1)
 
 (command "._style" "PMSF-TEXT" "Arial" 1.8 1 0 "n" "n" "n")
    (command "text"
             (list (+ (atof xstr) (/ (atof httt) 2.0)) (cadr gptx))
             httt
             "0"
             (strcat xstr)
    )
    (command "text"
             (list (+ (atof xstr) (/ (atof httt) 2.0)) (cadr gpty))
             httt
             "0"
             (strcat ystr)
    )
 
  )                                     ; foreach
 
)                                       ; write-vertices
 
 
(defun SPACES (STR / FIELD NUM CHAR SPACE)
  (setq FIELD 15
        NUM   (- FIELD (strlen STR))
        CHAR  " "
        SPACE ""
  ) ;_ setq
  (repeat NUM (setq SPACE (strcat SPACE CHAR))) ;_ repeat
) ;_ spaces
 
(defun C:vd2 () (SETTING) (VERTEXT) (RESETTING) (princ)) ; c:nsl
 
 

Thanks

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on April 03, 2019, 02:47:32 PM

no one ? :-(

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on April 04, 2019, 10:05:47 AM

it is important .Can anyone help ?:-(

Thanks

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on April 07, 2019, 12:28:54 PM

Hi i update this code but i need litle help. I want the thext style have the name PMSF-TEXT with Arial and the mtext be midle center not left

Code - Auto/Visual Lisp: [Select]

 
(defun ERR (S)
  (if (= S "Function cancelled")
    (princ "\nVERTEXT - cancelled: ")
    (progn (princ "\nVERTEXT - Error: ") (princ S) (terpri))
  )
  (RESETTING)
  (princ "SYSTEM VARIABLES have been reset\n")
  (princ)
)
(defun SETV (SYSTVAR NEWVAL)
  (setq X (read (strcat SYSTVAR "1")))
  (set X (getvar SYSTVAR))
  (setvar SYSTVAR NEWVAL)
)
(defun SETTING ()
  (setq OERR *ERROR*)
  (setq *ERROR* ERR)
  (SETV "CMDECHO" 0)
  (SETV "BLIPMODE" 0)
)
(defun RSETV (SYSTVAR)
  (setq X (read (strcat SYSTVAR "1")))
  (setvar SYSTVAR (eval X))
)
 
(defun RESETTING ()
  (RSETV "CMDECHO")
  (RSETV "BLIPMODE")
  (setq *ERROR* OERR)
)
 
 
(defun DXF (CODE ENAME) (cdr (assoc CODE (entget ENAME)))) ; dxf
 
(defun VERTEXT (/ EN VLIST)
  (setq EN (GET-EN))
  (if (= (DXF 0 EN) "LWPOLYLINE")
    (setq VLIST (GET-LWVLIST EN))
    (setq VLIST (GET-PLVLIST EN))
  )
  (WRITE-IT VLIST EN)
)
 
(defun GET-EN (/ NO-ENT EN MSG1 MSG2)
  (setq NO-ENT 1
        EN     NIL
        MSG1   "\nSelect a polyline: "
        MSG2   "\nNo polyline selected, try again."
  )                                     ; setq
  (while NO-ENT
    (setq EN (car (entsel MSG1)))
    (if (and EN
             (or (= (DXF 0 EN) "LWPOLYLINE") (= (DXF 0 EN) "POLYLINE"))
                                        ; or
        )                               ; and
      (progn (setq NO-ENT NIL))         ; progn
      (prompt MSG2)
    )                                   ; if
  )                                     ; while
  EN
)                                       ; get-en
 
(defun GET-LWVLIST (EN / ELIST NUM-VERT VLIST)
  (setq ELIST    (entget EN)
        NUM-VERT (cdr (assoc 90 ELIST))
        ELIST    (member (assoc 10 ELIST) ELIST)
        VLIST    NIL
  )                                     ; setq
  (repeat NUM-VERT
    (setq VLIST (append VLIST (list (cdr (assoc 10 ELIST)))) ; append
    )                                   ; setq
    (setq ELIST (cdr ELIST)
          ELIST (member (assoc 10 ELIST) ELIST)
    )                                   ; setq
  )                                     ; repeat
  VLIST
)                                       ; get-lwvlist
 
(defun GET-PLVLIST (EN / VLIST)
  (setq VLIST NIL
        EN    (entnext EN)
  )                                     ; setq
  (while (/= "SEQEND" (DXF 0 EN))
    (setq VLIST (append VLIST (list (DXF 10 EN))))
    (setq EN (entnext EN))
  )                                     ; while
  VLIST
)                                       ; get-plvlist
 
(defun WRITE-IT (VLST EN / NEWVLIST MSG3 FNAME)
  (setq NEWVLIST (mapcar '(lambda (X) (trans X EN 0)) ;_ lambda
                         VLST
                 ) ;_ mapcar
        MSG3     "Polyline vertex file"
                                        ;FNAME    (getfiled MSG3 "" "txt" 1)
        F1       (open "FNAME" "w")
  )                                     ; setq
  (WRITE-HEADER)
  (WRITE-VERTICES NEWVLIST)
  (setq F1 (close F1))
) ;_ write-it
 
(defun WRITE-HEADER (/ STR)
  (setq STR "        POLYLINE VERTEX POINTS")
  (write-line STR F1)
  (setq STR (strcat "  X            " "  Y            " "  Z") ;_ strcat
  ) ;_ setq
  (write-line STR F1)
) ;_ write-header
 
 
(defun WRITE-VERTICES (NEWVLIST / XSTR YSTR ZSTR STR)
  (setq httt "0.3")
  (setq gptx (getpoint "\nBasepoint for X axis: "))
  (setq gpty (getpoint "\nBasepoint for Y axis: "))
 
  (foreach ITEM NEWVLIST
    (setq XSTR (rtos (nth 0 ITEM) 2 2)
          YSTR (rtos (/ (nth 1 ITEM) 10) 2 2)
          ZSTR (rtos (nth 2 ITEM) 2 2)
          STR  (strcat XSTR (SPACES XSTR) YSTR (SPACES YSTR) ZSTR) ;_ strcat
    )                                   ; setq
                                        ;      (write-line STR F1)
 
 
 
    (command "text"
             (list (+ (atof xstr) (/ (atof httt) 2.0)) (cadr gptx))
             httt
             "0"
             (strcat xstr)
    )
    (command "text"
             (list (+ (atof xstr) (/ (atof httt) 2.0)) (cadr gpty))
             httt
             "0"
             (strcat ystr)
    )
 
  )                                     ; foreach
 
)                                       ; write-vertices
 
 
(defun SPACES (STR / FIELD NUM CHAR SPACE)
  (setq FIELD 15
        NUM   (- FIELD (strlen STR))
        CHAR  " "
        SPACE ""
  ) ;_ setq
  (repeat NUM (setq SPACE (strcat SPACE CHAR))) ;_ repeat
) ;_ spaces
 
(defun C:vv () (SETTING) (VERTEXT) (RESETTING) (princ)) ; c:nsl
 
(prompt "\nwritten by ENGR..Mr.Muhammad USMAN SOHAIL #03008342153")
(prompt "\nEnter VV to start")
 
 

Thanks

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on April 07, 2019, 12:54:48 PM

i find it .
Thanks

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: pedroantonio on April 07, 2019, 01:57:19 PM

Hi i update the code again but i am confused and i need some help. I want when i choose ground1 to use chainage Ground 1 layer and Elev Ground 1 layer, and when i choose ground2 to
give me two options
a) use chainage Ground 2 layer and Elev Ground 2 layer
b) use Elev Ground 2 layer and not print the chainage

Code - Auto/Visual Lisp: [Select]

 
(defun ERR (S)
  (if (= S "Function cancelled")
    (princ "\nVERTEXT - cancelled: ")
    (progn (princ "\nVERTEXT - Error: ") (princ S) (terpri))
  )
  (RESETTING)
  (princ "SYSTEM VARIABLES have been reset\n")
  (princ)
)
(defun SETV (SYSTVAR NEWVAL)
  (setq X (read (strcat SYSTVAR "1")))
  (set X (getvar SYSTVAR))
  (setvar SYSTVAR NEWVAL)
)
(defun SETTING ()
  (setq OERR *ERROR*)
  (setq *ERROR* ERR)
  (SETV "CMDECHO" 0)
  (SETV "BLIPMODE" 0)
)
(defun RSETV (SYSTVAR)
  (setq X (read (strcat SYSTVAR "1")))
  (setvar SYSTVAR (eval X))
)
 
(defun RESETTING ()
  (RSETV "CMDECHO")
  (RSETV "BLIPMODE")
  (setq *ERROR* OERR)
)
 
 
(defun DXF (CODE ENAME) (cdr (assoc CODE (entget ENAME)))) ; dxf
 
(defun VERTEXT (/ EN VLIST)
  (setq EN (GET-EN))
  (if (= (DXF 0 EN) "LWPOLYLINE")
    (setq VLIST (GET-LWVLIST EN))
    (setq VLIST (GET-PLVLIST EN))
  )
  (WRITE-IT VLIST EN)
)
 
(defun GET-EN (/ NO-ENT EN MSG1 MSG2)
  (setq NO-ENT 1
        EN     NIL
        MSG1   "\nSelect a polyline: "
        MSG2   "\nNo polyline selected, try again."
  )                                     ; setq
  (while NO-ENT
    (setq EN (car (entsel MSG1)))
    (if (and EN
             (or (= (DXF 0 EN) "LWPOLYLINE") (= (DXF 0 EN) "POLYLINE"))
                                        ; or
        )                               ; and
      (progn (setq NO-ENT NIL))         ; progn
      (prompt MSG2)
    )                                   ; if
  )                                     ; while
  EN
)                                       ; get-en
 
(defun GET-LWVLIST (EN / ELIST NUM-VERT VLIST)
  (setq ELIST    (entget EN)
        NUM-VERT (cdr (assoc 90 ELIST))
        ELIST    (member (assoc 10 ELIST) ELIST)
        VLIST    NIL
  )                                     ; setq
  (repeat NUM-VERT
    (setq VLIST (append VLIST (list (cdr (assoc 10 ELIST)))) ; append
    )                                   ; setq
    (setq ELIST (cdr ELIST)
          ELIST (member (assoc 10 ELIST) ELIST)
    )                                   ; setq
  )                                     ; repeat
  VLIST
)                                       ; get-lwvlist
 
(defun GET-PLVLIST (EN / VLIST)
  (setq VLIST NIL
        EN    (entnext EN)
  )                                     ; setq
  (while (/= "SEQEND" (DXF 0 EN))
    (setq VLIST (append VLIST (list (DXF 10 EN))))
    (setq EN (entnext EN))
  )                                     ; while
  VLIST
)                                       ; get-plvlist
 
(defun WRITE-IT (VLST EN / NEWVLIST MSG3 FNAME)
  (setq NEWVLIST (mapcar '(lambda (X) (trans X EN 0)) ;_ lambda
                         VLST
                 ) ;_ mapcar
        MSG3     "Polyline vertex file"
                                        ;FNAME    (getfiled MSG3 "" "txt" 1)
        F1       (open "FNAME" "w")
  )                                     ; setq
  (WRITE-HEADER)
  (WRITE-VERTICES NEWVLIST)
  (setq F1 (close F1))
) ;_ write-it
 
(defun WRITE-HEADER (/ STR)
  (setq STR "        POLYLINE VERTEX POINTS")
  (write-line STR F1)
  (setq STR (strcat "  X            " "  Y            " "  Z") ;_ strcat
  ) ;_ setq
  (write-line STR F1)
) ;_ write-header
 
 
(defun WRITE-VERTICES (NEWVLIST / XSTR YSTR ZSTR STR)
   (setvar 'OSMODE 64)
(progn
           (initget "1 2")
           (setq
             l
              (cond
                ((getkword
                   "\nGround 1 (1)/ Ground 2(2) < 1 > :"
                 )
                )
                ("1")
              )
           )
       
(if (eq l "1")
        (COMMAND "_layer" "_m" "chainage  Ground 1" "_c" "7" "" "")
        (COMMAND "_layer" "_m" "Elev  Ground 1" "_c" "7" "" "")
       )
       (if (eq l "2")
        (COMMAND "_layer" "_m" "chainage Ground 2" "_c" "7" "" "")
        (COMMAND "_layer" "_m" "Elev  Ground 2" "_c" "7" "" "")
           )
)
  (setq httt "1.8")
  (setq gptx (getpoint "\nBasepoint for X axis: "))
  (setq gpty (getpoint "\nBasepoint for Y axis: "))
 
  (foreach ITEM NEWVLIST
    (setq XSTR (rtos (nth 0 ITEM) 2 2)
          YSTR (rtos (/ (nth 1 ITEM) 10) 2 2)
          ZSTR (rtos (nth 2 ITEM) 2 2)
          STR  (strcat XSTR (SPACES XSTR) YSTR (SPACES YSTR) ZSTR) ;_ strcat
    )                                   ; setq
                                        ;      (write-line STR F1)
 
 (command "style" "PMSF-TEXT 2" "Arial" "" "" "" "" "")
    (command "text" "_mc"
             (list (+ (atof xstr) (/ (atof httt) 2.0)) (cadr gptx))
             httt
             "0"
             (strcat xstr)
    )
    (command "text" "_mc"
             (list (+ (atof xstr) (/ (atof httt) 2.0)) (cadr gpty))
             httt
             "0"
             (strcat ystr)
    )
 
  )                                     ; foreach
 
)                                       ; write-vertices
 
 
(defun SPACES (STR / FIELD NUM CHAR SPACE)
  (setq FIELD 15
        NUM   (- FIELD (strlen STR))
        CHAR  " "
        SPACE ""
  ) ;_ setq
  (repeat NUM (setq SPACE (strcat SPACE CHAR))) ;_ repeat
) ;_ spaces
 
(defun C:vv () (SETTING) (VERTEXT) (RESETTING) (princ)) ; c:nsl
 
(prompt "\nwritten by ENGR..Mr.Muhammad USMAN SOHAIL #03008342153")
(prompt "\nEnter VV to start")
 
 

Thanks

Title: Re: QUICK PROFILE LISP- hELP WITH UPDATE
Post by: MPD on January 17, 2021, 12:43:57 AM

Hi
how can i draw two profiles or more at once?
i want to pick ground and then the road
I use "Pedro Miguel da Silva Ferreira" lisp

TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: pedroantonio on March 02, 2019, 06:31:14 AM