Author Topic: QUICK PROFILE LISP- hELP WITH UPDATE  (Read 3538 times)

0 Members and 1 Guest are viewing this topic.

pedroantonio

  • Guest
QUICK PROFILE LISP- hELP WITH UPDATE
« 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]
  1. ;;; CADALYST 09/06  Tip 2149: QuickProfile.lsp  Center Line Profile     (c) 2006 Pedro Ferreira
  2.  
  3.  
  4. ;;;Author: Pedro Miguel da Silva Ferreira       Email:pedro_ferreira@netcabo.pt or pferreira@wsatkins.pt
  5. ;;;Web page: http:pwp.netcabo.pt/pedro_ferreira
  6. ;;;Location: Portugal, Lisboa
  7. ;;;RDS: PMSF
  8. ;;;Command Name: qp
  9. ;;;Date: 09 of May 2006
  10. ;;;Version: 1.0
  11. ;;;Description: Visual Lisp Routine that creates a section profile of the terrain based on the existing contours.
  12.  
  13.  
  14.  
  15. (defun timeini ()
  16.   (setq s (getvar "DATE"))
  17.   (setq seconds (* 86400.0 (- s (fix s))))
  18. )
  19.  
  20. (defun timeend ()
  21.   (setq s1 (getvar "DATE"))
  22.   (setq seconds1 (* 86400.0 (- s1 (fix s1))))
  23.   (setq seconds2 (fix (- seconds1 seconds)))
  24.   (princ
  25.     (strcat "\nTime : "
  26.             (itoa seconds2)
  27.             " seconds"
  28.     )
  29.   )
  30. )
  31.  
  32. (defun inivar ()
  33.   (setq cmd_ini (getvar "cmdecho")
  34.         fla_ini (getvar "flatland")
  35.         osm_ini (getvar "osmode")
  36.         ort_ini (getvar "orthomode")
  37.         plt_ini (getvar "plinetype")
  38.         aup_ini (getvar "auprec")
  39.         uni_ini (getvar "unitmode")
  40.         lun_ini (getvar "lunits")
  41.         diz_ini (getvar "dimzin")
  42.         edg_ini (getvar "edgemode")
  43.   )
  44.   (setvar "CMDECHO" 0)
  45.   (setvar "FLATLAND" 0)
  46.   (setvar "OSMODE" 0)
  47.   (setvar "ORTHOMODE" 0)
  48.   (setvar "PLINETYPE" 2)
  49.   (setvar "AUPREC" 0)
  50.   (setvar "UNITMODE" 1)
  51.   (setvar "LUNITS" 2)
  52.   (setvar "DIMZIN" 0)
  53.   (setvar "EDGEMODE" 1)
  54. )
  55.  
  56. (defun recvar ()
  57.   (setvar "CMDECHO" cmd_ini)
  58.   (setvar "FLATLAND" fla_ini)
  59.   (setvar "OSMODE" osm_ini)
  60.   (setvar "ORTHOMODE" ort_ini)
  61.   (setvar "PLINETYPE" plt_ini)
  62.   (setvar "AUPREC" aup_ini)
  63.   (setvar "UNITMODE" uni_ini)
  64.   (setvar "LUNITS" lun_ini)
  65.   (setvar "DIMZIN" diz_ini)
  66.   (setvar "EDGEMODE" edg_ini)
  67. )
  68.  
  69. (defun getlayname ()
  70.   (setq contourstest nil)
  71.   (setq layername
  72.          (getstring
  73.            "\nPlease enter the layer name of the contours: "
  74.          )
  75.   )
  76.   (setq contourstest
  77.          (ssget "_x"
  78.                 (list (cons -4 "<OR")
  79.                       (cons -4 "<AND")
  80.                       (cons 0 "lwpolyline")
  81.                       (cons 8 layername)
  82.                       (cons -4 "AND>")
  83.                       (cons -4 "<AND")
  84.                       (cons 0 "polyline")
  85.                       (cons 8 layername)
  86.                       (cons -4 "AND>")
  87.                       (cons -4 "<AND")
  88.                       (cons 0 "line")
  89.                       (cons 8 layername)
  90.                       (cons -4 "AND>")
  91.                       (cons -4 "<AND")
  92.                       (cons 0 "spline")
  93.                       (cons 8 layername)
  94.                       (cons -4 "AND>")
  95.                       (cons -4 "OR>")
  96.                 )
  97.          )
  98.   )
  99.  
  100.   (while (= contourstest nil)
  101.     (princ "\nNo contours selected...")
  102.     (setq layername
  103.            (getstring
  104.              "\nPlease enter the layer name of the contours: "
  105.            )
  106.     )
  107.     (setq contourstest
  108.            (ssget "_x"
  109.                   (list (cons -4 "<OR")
  110.                         (cons -4 "<AND")
  111.                         (cons 0 "lwpolyline")
  112.                         (cons 8 layername)
  113.                         (cons -4 "AND>")
  114.                         (cons -4 "<AND")
  115.                         (cons 0 "polyline")
  116.                         (cons 8 layername)
  117.                         (cons -4 "AND>")
  118.                         (cons -4 "<AND")
  119.                         (cons 0 "line")
  120.                         (cons 8 layername)
  121.                         (cons -4 "AND>")
  122.                         (cons -4 "<AND")
  123.                         (cons 0 "spline")
  124.                         (cons 8 layername)
  125.                         (cons -4 "AND>")
  126.                         (cons -4 "OR>")
  127.                   )
  128.            )
  129.     )
  130.   )
  131. )
  132.  
  133. (defun activexsupport ()
  134.   (setq *modelspace*
  135.          (vla-get-modelspace
  136.          )
  137.   )
  138. )
  139.  
  140. (defun esttexto ()
  141.  
  142.   (vl-cmdf "._style" "PMSF-TEXT" "romans" 2.50 0.80 0 "n" "n" "n")
  143. )
  144.  
  145. (defun getha ()
  146.   ;; this entity must be a lwpolyline
  147.   (activexsupport)
  148.   (setq
  149.     ha (entsel "\nSelect the Horizontal alignment: ")
  150.   )
  151.   (while (= ha nil)
  152.     (progn
  153.       (princ "\nNothing selected...")
  154.       (setq ha
  155.              (entsel "\nSelect the Horizontal alignment: ")
  156.       )
  157.     )
  158.   )
  159.   (setq ha-type (cdr (assoc 0 (entget (car ha)))))
  160.   (if (not (equal ha-type "LWPOLYLINE"))
  161.     (progn
  162.       (setq ha nil)
  163.       (princ "\n***Horizontal Alignment must be a LWPolyline***")
  164.     )
  165.   )
  166.   (while (= ha nil)
  167.     (progn
  168.       (princ "\nNothing selected...")
  169.       (setq ha
  170.              (entsel "\nSelect the Horizontal alignment: ")
  171.       )
  172.       (setq ha-type (cdr (assoc 0 (entget (car ha)))))
  173.       (if (not (equal ha-type "LWPOLYLINE"))
  174.         (progn
  175.           (setq ha nil)
  176.           (princ "\n***Horizontal Alignment must be a LWPolyline***")
  177.         )
  178.       )
  179.     )
  180.   )
  181.   (setq ha-ename (entget (car ha)))
  182.   (setq ha-ename (cdr (assoc -1 ha-ename)))
  183.   (setq ha-object (vlax-ename->vla-object ha-ename))
  184.  
  185.   (vl-cmdf "._text"
  186.            (vlax-curve-getstartpoint ha-object)
  187.            "0"
  188.            "A"
  189.   )
  190.   (vl-cmdf "._text"
  191.            (vlax-curve-getendpoint ha-object)
  192.            "0"
  193.            "B"
  194.   )
  195. )
  196.  
  197. (defun getexaggeration ()
  198.   (initget 2)
  199.   (setq ve (getreal "\nEnter the vertical exaggeration <1>: "))
  200.   (if (= ve nil)
  201.     (setq ve 1)
  202.   )
  203. )
  204.  
  205.  
  206. (defun listptintersect ()
  207.   (setq listaxy nil)
  208.  
  209.   (setq hazvalue (caddr (vlax-curve-getStartPoint ha-object)))
  210.  
  211.   (setq curvas contourstest)
  212.   (setq ncurvas (sslength curvas))
  213.   (setq listaxy nil)
  214.   (setq counter 0)
  215.   (while (< counter ncurvas)
  216.     (progn
  217.       (setq cnivel-ename (ssname curvas counter))
  218.       (setq cnivel-object (vlax-ename->vla-object cnivel-ename))
  219.  
  220.       (setq cnivelzvalue
  221.              (caddr (vlax-curve-getStartPoint cnivel-object))
  222.       )
  223.  
  224.       (setq ha-ENTITY
  225.              (subst (cons 38 cnivelzvalue)
  226.                     (assoc 38 (entget (car ha)))
  227.                     (entget (car ha))
  228.              )
  229.       )
  230.       (entmod ha-ENTITY)
  231.  
  232.       (setq intersectpt
  233.              (vlax-variant-value
  234.                (vlax-invoke-method
  235.                  ha-object
  236.                  "IntersectWith"
  237.                  cnivel-object
  238.                  acExtendNone
  239.                )
  240.              )
  241.       )
  242.  
  243.       (setq test nil)
  244.       (setq
  245.         test (vl-catch-all-apply
  246.                'vlax-safearray->list
  247.                (list intersectpt)
  248.              )
  249.       )
  250.       (setq error (vl-catch-all-error-p test))
  251.  
  252.       (if (/= error t)
  253.         (progn
  254.           (setq intersectpt (vlax-safearray->list intersectpt))
  255.           (setq interlength (length intersectpt))
  256.  
  257.           (if (> interlength 3)
  258.             (progn
  259.               (setq dividelength (/ interlength 3))
  260.               (setq count 0)
  261.               (while (< count interlength)
  262.                 (progn
  263.                   (setq newpt (list (nth count intersectpt)
  264.                                     (nth (+ count 1) intersectpt)
  265.                                     (nth (+ count 2) intersectpt)
  266.                               )
  267.                   )
  268.  
  269.                   (setq x (vlax-curve-getdistatPoint ha-ename newpt))
  270.                   (setq z (caddr intersectpt))
  271.                   (setq xy (list x (* z ve)))
  272.                   (setq
  273.                     listaxy (append listaxy (list xy))
  274.                   )
  275.  
  276.                   (setq count (+ count 3))
  277.                 )
  278.               )
  279.             )
  280.             (progn
  281.               (setq x (vlax-curve-getdistatPoint ha-ename intersectpt))
  282.               (setq z (caddr intersectpt))
  283.               (setq xy (list x (* z ve)))
  284.               (setq
  285.                 listaxy (append listaxy (list xy))
  286.               )
  287.             )
  288.           )
  289.  
  290.           (setq ha-ENTITY
  291.                  (subst (cons 38 hazvalue)
  292.                         (assoc 38 (entget (car ha)))
  293.                         (entget (car ha))
  294.                  )
  295.           )
  296.           (entmod ha-ENTITY)
  297.         )
  298.       )
  299.       (setq counter (1+ counter))
  300.     )
  301.   )
  302.  
  303.   (setq listaxy
  304.          (vl-sort listaxy
  305.                   (function (lambda (e1 e2)
  306.                               (< (car e1) (car e2))
  307.                             )
  308.                   )
  309.          )
  310.   )
  311.  
  312.                     ha-ename
  313.                     (vlax-curve-getstartpoint ha-ename)
  314.                   )
  315.         enddist   (vlax-curve-getdistatPoint
  316.                     ha-ename
  317.                     (vlax-curve-getendpoint ha-ename)
  318.                   )
  319.   )
  320.  
  321.   (setq pt1 (car (car listaxy))
  322.         pt2 (car (last listaxy))
  323.   )
  324.  
  325.   (if (/= startdist pt1)
  326.     (progn
  327.       (setq x startdist)
  328.       (setq y (+ (* (/ (- (cadr (car listaxy)) (cadr (cadr listaxy)))
  329.                        (- (car (cadr listaxy)) (car (car listaxy)))
  330.                     )
  331.                     (- (car (car listaxy)) startdist)
  332.                  )
  333.                  (cadr (car listaxy))
  334.               )
  335.       )
  336.       (setq xy (list x y))
  337.       (setq
  338.         listaxy (append listaxy (list xy))
  339.       )
  340.       (setq listaxy
  341.              (vl-sort listaxy
  342.                       (function (lambda (e1 e2)
  343.                                   (< (car e1) (car e2))
  344.                                 )
  345.                       )
  346.              )
  347.       )
  348.  
  349.     )
  350.   )
  351.  
  352.   (if (/= enddist pt1)
  353.     (progn
  354.       (setq pos (1- (length listaxy)))
  355.       (setq x enddist)
  356.       (setq y
  357.              (+
  358.                (*
  359.                  (/ (- (cadr (nth pos listaxy))
  360.                        (cadr (nth (1- pos) listaxy))
  361.                     )
  362.                     (- (car (nth pos listaxy)) (car (nth (1- pos) listaxy)))
  363.                  )
  364.                  (- enddist (car (nth pos listaxy)))
  365.                )
  366.                (cadr (nth pos listaxy))
  367.              )
  368.       )
  369.       (setq xy (list x y))
  370.       (setq
  371.         listaxy (append listaxy (list xy))
  372.       )
  373.       (setq listaxy
  374.              (vl-sort listaxy
  375.                       (function (lambda (e1 e2)
  376.                                   (< (car e1) (car e2))
  377.                                 )
  378.                       )
  379.              )
  380.       )
  381.  
  382.     )
  383.   )
  384. )
  385.  
  386. (defun createprofile ()
  387. (COMMAND "_layer" "_m" "NATURAL GROUND" "_c" "94" "" "")
  388.   (setq variante-listaxy (apply 'append listaxy))
  389.  
  390.   (setq arraySpace
  391.          (vlax-make-safearray
  392.            vlax-vbdouble
  393.            (cons 0
  394.                  (- (length variante-listaxy) 1)
  395.            )
  396.          )
  397.   )
  398.   (setq variante-listaxy
  399.          (vlax-safearray-fill arraySpace variante-listaxy)
  400.   )
  401.  
  402.   (vlax-make-variant variante-listaxy)
  403.  
  404.  
  405.                 *ModelSpace*
  406.                 variante-listaxy
  407.               )
  408.   )
  409.  
  410.  
  411.   (vl-cmdf "._text"
  412.            (vlax-curve-getstartpoint pline)
  413.            "0"
  414.            "A"
  415.   )
  416.   (vl-cmdf "._text"
  417.            (vlax-curve-getendpoint pline)
  418.            "0"
  419.            "B"
  420.   )
  421. )
  422.  
  423. (defun annotate ()
  424.   (setq xini (car (vlax-curve-getstartpoint pline))
  425.         xend (car (vlax-curve-getendpoint pline))
  426.         y    (* (fix
  427.                   (/ (cadr (car (vl-sort listaxy
  428.                                          (function (lambda (e1 e2)
  429.                                                      (< (cadr e1) (cadr e2))
  430.                                                    )
  431.                                          )
  432.                                 )
  433.                            )
  434.                      )
  435.                      ve
  436.                   )
  437.                 )
  438.                 ve
  439.              )
  440.   )
  441.   ;;end setq
  442.  
  443.   (if (< y 0)
  444.     (setq y (- y (* 1 ve)))
  445.   )
  446.  
  447.   (setq var-xyini (apply 'append (list (list xini y 0))))
  448.   (setq var-xyend (apply 'append (list (list xend y 0))))
  449.   (createline)
  450.   (COMMAND "_layer" "_m" "REFERENCE" "_c" "12" "" "")
  451.   (setq yref (strcat "REFERENCE: " (rtos (/ y ve) 2 2)))
  452.   (setq ptloc (list (- xini 30.0) y))
  453.   (vl-cmdf "._text" ptloc "0" yref)
  454.  
  455.  
  456.  
  457.  
  458.   (setq lengthlistaxy (length listaxy))
  459.   (setq count 0)
  460.   (while (< count lengthlistaxy)
  461.     (progn
  462.       (setq var-xyini (apply 'append
  463.                              (list (list (car (nth count listaxy))
  464.                                          (cadr (nth count listaxy))
  465.                                          0
  466.                                    )
  467.                              )
  468.                       )
  469.       )
  470.       (setq
  471.         var-xyend (apply 'append
  472.                          (list (list (car (nth count listaxy)) y 0))
  473.                   )
  474.       )
  475.       (createline)
  476. (COMMAND "_layer" "_m" "NATURAL GROUND ELEV TEXT" "_c" "94" "" "")
  477.       (setq ytext (rtos (/ (cadr (nth count listaxy)) ve) 2 2))
  478.       (setq xpt (car (nth count listaxy)))
  479.       (setq ptloc (list xpt (- y 10.0)))
  480.       (vl-cmdf "._text" ptloc "90" ytext)
  481.  
  482.       (setq count (1+ count))
  483.     )
  484.   )
  485.  
  486.  
  487.  
  488.  
  489. )
  490.  
  491.  
  492.  
  493. (defun createline ()
  494. (COMMAND "_layer" "_m" "LINE" "_c" "155" "" "")
  495.   (setq arraySpace
  496.          (vlax-make-safearray
  497.            vlax-vbdouble
  498.            (cons 0
  499.                  (- (length var-xyini) 1)
  500.            )
  501.          )
  502.   )
  503.   (setq var-xyini
  504.          (vlax-safearray-fill arraySpace var-xyini)
  505.   )
  506.  
  507.   (vlax-make-variant var-xyini)
  508.  
  509.   (setq arraySpace
  510.          (vlax-make-safearray
  511.            vlax-vbdouble
  512.            (cons 0
  513.                  (- (length var-xyend) 1)
  514.            )
  515.          )
  516.   )
  517.   (setq var-xyend
  518.          (vlax-safearray-fill arraySpace var-xyend)
  519.   )
  520.  
  521.   (vlax-make-variant var-xyend)
  522.  
  523.   (setq line (vla-addline
  524.                *ModelSpace*
  525.                var-xyini
  526.                var-xyend
  527.              )
  528.   )
  529.  
  530. )
  531.  
  532.  
  533.  
  534.  
  535. (defun c:qp ()
  536.   (timeini)
  537.   (inivar)
  538.   (getlayname)
  539.   (esttexto)
  540.   (getha)
  541.   (getexaggeration)
  542.   (listptintersect)
  543.   (createprofile)
  544.   (annotate)
  545.  
  546.   (vl-cmdf "._zoom"
  547.            (vlax-curve-getstartpoint pline)
  548.            (vlax-curve-getendpoint pline)
  549.   )
  550.   (recvar)
  551.   (timeend)
  552.   (command "setvar" "clayer" "0")
  553.   (princ)
  554. )
  555.  
  556.  

kdub

  • Mesozoic relic
  • SuperMod
  • Swamp Rat
  • Posts: 1383
  • class keyThumper<T>:ILazy<T>
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #1 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.??



called Kerry in my other life

Sometimes the question is more important than the answer.
#ridesober

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #2 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

kdub

  • Mesozoic relic
  • SuperMod
  • Swamp Rat
  • Posts: 1383
  • class keyThumper<T>:ILazy<T>
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #3 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 ?


called Kerry in my other life

Sometimes the question is more important than the answer.
#ridesober

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #4 on: March 02, 2019, 05:38:00 PM »
The lisp ask
Code - Auto/Visual Lisp: [Select]
  1. (setq   layername
  2.          (getstring
  3.            "\nPlease enter the layer name of the contours: "
  4.          )
  5.  

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

sanju2323

  • Newt
  • Posts: 67
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #5 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)
)
 
« Last Edit: March 03, 2019, 02:24:33 AM by sanju2323 »

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #6 on: March 03, 2019, 02:47:05 AM »
Thank you  sanju2323  :-D

sanju2323

  • Newt
  • Posts: 67
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #7 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)
)
« Last Edit: March 03, 2019, 10:37:54 AM by sanju2323 »

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #8 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
« Last Edit: March 03, 2019, 12:28:02 PM by Topographer »

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #9 on: March 03, 2019, 02:55:21 PM »
i find it.


Code - Auto/Visual Lisp: [Select]
  1.   (vl-cmdf "._text" "_bc" ptloc "100" yref)

Code - Auto/Visual Lisp: [Select]
  1.       (vl-cmdf "._text" "_mc" ptloc "0" ytext)
  2.       (vl-cmdf "._text" "_mc" ptloc2 "0" xtext)
  3.  

Thanks


pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #10 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]
  1. ;;;Author: Pedro Miguel da Silva Ferreira       Email:pedro_ferreira@netcabo.pt or pferreira@wsatkins.pt
  2. ;;;Web page: http:pwp.netcabo.pt/pedro_ferreira
  3. ;;;Location: Portugal, Lisboa
  4. ;;;RDS: PMSF
  5. ;;;Command Name: qp
  6. ;;;Date: 09 of May 2006
  7. ;;;Version: 1.0
  8. ;;;Description: Visual Lisp Routine that creates a section profile of the terrain based on the existing contours.
  9. ;;;Modified 11/20/09 CAB request of ttxxx of AutoLisp Forum, to print chainage info, tabular form
  10.  
  11.  
  12. (defun timeini ()
  13.   (setq s (getvar "DATE"))
  14.   (setq seconds (* 86400.0 (- s (fix s))))
  15. )
  16.  
  17. (defun timeend ()
  18.   (setq s1 (getvar "DATE"))
  19.   (setq seconds1 (* 86400.0 (- s1 (fix s1))))
  20.   (setq seconds2 (fix (- seconds1 seconds)))
  21.   (princ
  22.     (strcat "\nTime : "
  23.             (itoa seconds2)
  24.             " seconds"
  25.     )
  26.   )
  27. )
  28.  
  29. (defun inivar ()
  30.   (setq cmd_ini (getvar "cmdecho")
  31.         fla_ini (getvar "flatland")
  32.         osm_ini (getvar "osmode")
  33.         ort_ini (getvar "orthomode")
  34.         plt_ini (getvar "plinetype")
  35.         aup_ini (getvar "auprec")
  36.         uni_ini (getvar "unitmode")
  37.         lun_ini (getvar "lunits")
  38.         diz_ini (getvar "dimzin")
  39.         edg_ini (getvar "edgemode")
  40.   )
  41.   (setvar "CMDECHO" 0)
  42.   (setvar "FLATLAND" 0)
  43.   (setvar "OSMODE" 0)
  44.   (setvar "ORTHOMODE" 0)
  45.   (setvar "PLINETYPE" 2)
  46.   (setvar "AUPREC" 0)
  47.   (setvar "UNITMODE" 1)
  48.   (setvar "LUNITS" 2)
  49.   (setvar "DIMZIN" 0)
  50.   (setvar "EDGEMODE" 1)
  51. )
  52.  
  53. (defun recvar ()
  54.   (setvar "CMDECHO" cmd_ini)
  55.   (setvar "FLATLAND" fla_ini)
  56.   (setvar "OSMODE" osm_ini)
  57.   (setvar "ORTHOMODE" ort_ini)
  58.   (setvar "PLINETYPE" plt_ini)
  59.   (setvar "AUPREC" aup_ini)
  60.   (setvar "UNITMODE" uni_ini)
  61.   (setvar "LUNITS" lun_ini)
  62.   (setvar "DIMZIN" diz_ini)
  63.   (setvar "EDGEMODE" edg_ini)
  64. )
  65.  
  66. ;; Unique  -  Lee Mac
  67. ;; Returns a list with duplicate elements removed.
  68. (defun LM:Unique (l / x r)
  69.   (while l
  70.     (setq x (car l)
  71.           l (vl-remove x (cdr l))
  72.           r (cons x r)
  73.     )
  74.   )
  75.   (reverse r)
  76. )
  77.  
  78. (defun getlayname (/ selset lyrset n ent)
  79.   (setq contourstest nil)
  80.   (while (= contourstest nil)
  81.     (prompt "\nSelect one or more entities to get Contours Layer(s) : ")
  82.     (setq selset (ssget "_X" (list (cons 0 "*LINE")))) ;(setq selset (ssget "_:L" '((0 . "*LINE"))))
  83.     (setq lyrset (list))
  84.     (repeat (setq n (sslength selset))
  85.       (setq ent (ssname selset (setq n (1- n))))
  86.       (setq lyrset (append lyrset (list (vla-get-layer (vlax-ename->vla-object ent)))))
  87.     )
  88.     (setq lyrset (LM:Unique lyrset))
  89.     (setq contourstest
  90.            (ssget "_X"
  91.                   (append '((0 . "*LINE") (-4 . "<OR")) (mapcar '(lambda (n) (cons 8 n)) lyrset) '((-4 . "OR>")))
  92.            )
  93.     )
  94.   )
  95. )
  96.  
  97. (defun activexsupport ()
  98.   (setq *modelspace*
  99.          (vla-get-modelspace
  100.          )
  101.   )
  102. )
  103.  
  104. (defun esttexto ()
  105.  
  106.   (vl-cmdf "._style" "PMSF-TEXT" "romans" 2.50 0.80 0 "n" "n" "n")
  107. )
  108.  
  109. (defun getha ()
  110.   ;; this entity must be a lwpolyline
  111.   (activexsupport)
  112.   (setq
  113.     ha (entsel "\nSelect the Horizontal alignment: ")
  114.   )
  115.   (while (= ha nil)
  116.     (progn
  117.       (princ "\nNothing selected...")
  118.       (setq ha
  119.              (entsel "\nSelect the Horizontal alignment: ")
  120.       )
  121.     )
  122.   )
  123.   (setq ha-type (cdr (assoc 0 (entget (car ha)))))
  124.   (if (not (equal ha-type "LWPOLYLINE"))
  125.     (progn
  126.       (setq ha nil)
  127.       (princ "\n***Horizontal Alignment must be a LWPolyline***")
  128.     )
  129.   )
  130.   (while (= ha nil)
  131.     (progn
  132.       (princ "\nNothing selected...")
  133.       (setq ha
  134.              (entsel "\nSelect the Horizontal alignment: ")
  135.       )
  136.       (setq ha-type (cdr (assoc 0 (entget (car ha)))))
  137.       (if (not (equal ha-type "LWPOLYLINE"))
  138.         (progn
  139.           (setq ha nil)
  140.           (princ "\n***Horizontal Alignment must be a LWPolyline***")
  141.         )
  142.       )
  143.     )
  144.   )
  145.   (setq ha-ename (entget (car ha)))
  146.   (setq ha-ename (cdr (assoc -1 ha-ename)))
  147.   (setq ha-object (vlax-ename->vla-object ha-ename))
  148.  
  149.   (vl-cmdf "._text"
  150.            (vlax-curve-getstartpoint ha-object)
  151.            "0"
  152.            "A"
  153.   )
  154.   (vl-cmdf "._text"
  155.            (vlax-curve-getendpoint ha-object)
  156.            "0"
  157.            "B"
  158.   )
  159. )
  160.  
  161. (defun getexaggeration ()
  162.   (initget 2)
  163.   (setq ve (getreal "\nEnter the vertical exaggeration <1>: "))
  164.   (if (= ve nil)
  165.     (setq ve 1)
  166.   )
  167. )
  168.  
  169.  
  170. (defun listptintersect ()
  171.   (setq listaxy nil)
  172.  
  173.   (setq hazvalue (caddr (vlax-curve-getStartPoint ha-object)))
  174.  
  175.   (setq curvas contourstest)
  176.   (setq ncurvas (sslength curvas))
  177.   (setq listaxy nil)
  178.   (setq counter 0)
  179.   (while (< counter ncurvas)
  180.     (progn
  181.       (setq cnivel-ename (ssname curvas counter))
  182.       (setq cnivel-object (vlax-ename->vla-object cnivel-ename))
  183.  
  184.       (setq cnivelzvalue
  185.              (caddr (vlax-curve-getStartPoint cnivel-object))
  186.       )
  187.  
  188.       (setq ha-ENTITY
  189.              (subst (cons 38 cnivelzvalue)
  190.                     (assoc 38 (entget (car ha)))
  191.                     (entget (car ha))
  192.              )
  193.       )
  194.       (entmod ha-ENTITY)
  195.  
  196.       (setq intersectpt
  197.              (vlax-variant-value
  198.                (vlax-invoke-method
  199.                  ha-object
  200.                  "IntersectWith"
  201.                  cnivel-object
  202.                  acExtendNone
  203.                )
  204.              )
  205.       )
  206.  
  207.       (setq test nil)
  208.       (setq
  209.         test (vl-catch-all-apply
  210.                'vlax-safearray->list
  211.                (list intersectpt)
  212.              )
  213.       )
  214.       (setq error (vl-catch-all-error-p test))
  215.  
  216.       (if (/= error t)
  217.         (progn
  218.           (setq intersectpt (vlax-safearray->list intersectpt))
  219.           (setq interlength (length intersectpt))
  220.  
  221.           (if (> interlength 3)
  222.             (progn
  223.               (setq dividelength (/ interlength 3))
  224.               (setq count 0)
  225.               (while (< count interlength)
  226.                 (progn
  227.                   (setq newpt (list (nth count intersectpt)
  228.                                     (nth (+ count 1) intersectpt)
  229.                                     (nth (+ count 2) intersectpt)
  230.                               )
  231.                   )
  232.  
  233.                   (setq x (vlax-curve-getdistatPoint ha-ename newpt))
  234.                   (setq z (caddr intersectpt))
  235.                   (setq xy (list x (* z ve)))
  236.                   (setq
  237.                     listaxy (append listaxy (list xy))
  238.                   )
  239.  
  240.                   (setq count (+ count 3))
  241.                 )
  242.               )
  243.             )
  244.             (progn
  245.               (setq x (vlax-curve-getdistatPoint ha-ename intersectpt))
  246.               (setq z (caddr intersectpt))
  247.               (setq xy (list x (* z ve)))
  248.               (setq
  249.                 listaxy (append listaxy (list xy))
  250.               )
  251.             )
  252.           )
  253.  
  254.           (setq ha-ENTITY
  255.                  (subst (cons 38 hazvalue)
  256.                         (assoc 38 (entget (car ha)))
  257.                         (entget (car ha))
  258.                  )
  259.           )
  260.           (entmod ha-ENTITY)
  261.         )
  262.       )
  263.       (setq counter (1+ counter))
  264.     )
  265.   )
  266.  
  267.   (setq listaxy
  268.          (vl-sort listaxy
  269.                   (function (lambda (e1 e2)
  270.                               (< (car e1) (car e2))
  271.                             )
  272.                   )
  273.          )
  274.   )
  275.  
  276.                     ha-ename
  277.                     (vlax-curve-getstartpoint ha-ename)
  278.                   )
  279.         enddist   (vlax-curve-getdistatPoint
  280.                     ha-ename
  281.                     (vlax-curve-getendpoint ha-ename)
  282.                   )
  283.   )
  284.  
  285.   (setq pt1 (car (car listaxy))
  286.         pt2 (car (last listaxy))
  287.   )
  288.  
  289.   (if (/= startdist pt1)
  290.     (progn
  291.       (setq x startdist)
  292.       (setq y (+ (* (/ (- (cadr (car listaxy)) (cadr (cadr listaxy)))
  293.                        (- (car (cadr listaxy)) (car (car listaxy)))
  294.                     )
  295.                     (- (car (car listaxy)) startdist)
  296.                  )
  297.                  (cadr (car listaxy))
  298.               )
  299.       )
  300.       (setq xy (list x y))
  301.       (setq
  302.         listaxy (append listaxy (list xy))
  303.       )
  304.       (setq listaxy
  305.              (vl-sort listaxy
  306.                       (function (lambda (e1 e2)
  307.                                   (< (car e1) (car e2))
  308.                                 )
  309.                       )
  310.              )
  311.       )
  312.  
  313.     )
  314.   )
  315.  
  316.   (if (/= enddist pt1)
  317.     (progn
  318.       (setq pos (1- (length listaxy)))
  319.       (setq x enddist)
  320.       (setq y
  321.              (+
  322.                (*
  323.                  (/ (- (cadr (nth pos listaxy))
  324.                        (cadr (nth (1- pos) listaxy))
  325.                     )
  326.                     (- (car (nth pos listaxy)) (car (nth (1- pos) listaxy)))
  327.                  )
  328.                  (- enddist (car (nth pos listaxy)))
  329.                )
  330.                (cadr (nth pos listaxy))
  331.              )
  332.       )
  333.       (setq xy (list x y))
  334.       (setq
  335.         listaxy (append listaxy (list xy))
  336.       )
  337.       (setq listaxy
  338.              (vl-sort listaxy
  339.                       (function (lambda (e1 e2)
  340.                                   (< (car e1) (car e2))
  341.                                 )
  342.                       )
  343.              )
  344.       )
  345.  
  346.     )
  347.   )
  348. )
  349.  
  350. (defun createprofile ()
  351. (COMMAND "_layer" "_m" "NATURAL GROUND" "_c" "94" "" "")
  352.   (setq variante-listaxy (apply 'append listaxy))
  353.  
  354.   (setq arraySpace
  355.          (vlax-make-safearray
  356.            vlax-vbdouble
  357.            (cons 0
  358.                  (- (length variante-listaxy) 1)
  359.            )
  360.          )
  361.   )
  362.   (setq variante-listaxy
  363.          (vlax-safearray-fill arraySpace variante-listaxy)
  364.   )
  365.  
  366.   (vlax-make-variant variante-listaxy)
  367.  
  368.  
  369.                 *ModelSpace*
  370.                 variante-listaxy
  371.               )
  372.   )
  373.  
  374.  
  375.   (vl-cmdf "._text"
  376.            (vlax-curve-getstartpoint pline)
  377.            "0"
  378.            "A"
  379.   )
  380.   (vl-cmdf "._text"
  381.            (vlax-curve-getendpoint pline)
  382.            "0"
  383.            "B"
  384.   )
  385. )
  386.  
  387. (defun annotate ()
  388.   (setq xini (car (vlax-curve-getstartpoint pline))
  389.         xend (car (vlax-curve-getendpoint pline))
  390.         y    (* (fix
  391.                   (/ (cadr (car (vl-sort listaxy
  392.                                          (function (lambda (e1 e2)
  393.                                                      (< (cadr e1) (cadr e2))
  394.                                                    )
  395.                                          )
  396.                                 )
  397.                            )
  398.                      )
  399.                      ve
  400.                   )
  401.                 )
  402.                 ve
  403.              )
  404.   )
  405.   ;;end setq
  406.  
  407.   (if (< y 0)
  408.     (setq y (- y (* 1 ve)))
  409.   )
  410.  
  411.   (setq var-xyini (apply 'append (list (list xini y 0))))
  412.   (setq var-xyend (apply 'append (list (list xend y 0))))
  413.   (createline)
  414.   (COMMAND "_layer" "_m" "REFERENCE" "_c" "12" "" "")
  415.   (setq yref (strcat "DATUM: " (rtos (/ y ve) 2 2)))
  416.   (setq ptloc (list (- xini 30.0) y))
  417.   (vl-cmdf "._text" "_bc" ptloc "100" yref)
  418.  
  419.  
  420.  
  421.  
  422.   (setq lengthlistaxy (length listaxy))
  423.   (setq count 0)
  424.   (while (< count lengthlistaxy)
  425.     (progn
  426.       (setq var-xyini (apply 'append
  427.                              (list (list (car (nth count listaxy))
  428.                                          (cadr (nth count listaxy))
  429.                                          0
  430.                                    )
  431.                              )
  432.                       )
  433.       )
  434.       (setq
  435.         var-xyend (apply 'append
  436.                          (list (list (car (nth count listaxy)) y 0))
  437.                   )
  438.       )
  439.       (createline)
  440.       (COMMAND "_layer" "_m" "Level" "_c" "94" "" "")
  441.       (setq ytext (rtos (/ (cadr (nth count listaxy)) ve) 2 2))
  442.       (setq xpt (car (nth count listaxy)))
  443.       (setq xtext (rtos xpt 2 2));;CB 11/24/09
  444.       (setq ptloc (list xpt (- y 10.0)))
  445.       (setq ptloc2 (list xpt (- y 30.0)));;CB 11/24/09
  446.       (vl-cmdf "._text" "_mc" ptloc "0" ytext)
  447.       (COMMAND "_layer" "_m" "Chainage" "_c" "94" "" "")
  448.       (vl-cmdf "._text" "_mc" ptloc2 "0" xtext);;CB 11/24/09
  449.  
  450.       (setq count (1+ count))
  451.     )
  452.   )
  453.  
  454. )
  455.  
  456.  
  457.  
  458. (defun createline ()
  459. (COMMAND "_layer" "_m" "LINE" "_c" "155" "" "")
  460.   (setq arraySpace
  461.          (vlax-make-safearray
  462.            vlax-vbdouble
  463.            (cons 0
  464.                  (- (length var-xyini) 1)
  465.            )
  466.          )
  467.   )
  468.   (setq var-xyini
  469.          (vlax-safearray-fill arraySpace var-xyini)
  470.   )
  471.  
  472.   (vlax-make-variant var-xyini)
  473.  
  474.   (setq arraySpace
  475.          (vlax-make-safearray
  476.            vlax-vbdouble
  477.            (cons 0
  478.                  (- (length var-xyend) 1)
  479.            )
  480.          )
  481.   )
  482.   (setq var-xyend
  483.          (vlax-safearray-fill arraySpace var-xyend)
  484.   )
  485.  
  486.   (vlax-make-variant var-xyend)
  487.  
  488.   (setq line (vla-addline
  489.                *ModelSpace*
  490.                var-xyini
  491.                var-xyend
  492.              )
  493.   )
  494.  
  495. )
  496.  
  497.  
  498. (defun c:qp ()
  499.   (timeini)
  500.   (inivar)
  501.   (getlayname)
  502.   (esttexto)
  503.   (getha)
  504.   (getexaggeration)
  505.   (listptintersect)
  506.   (createprofile)
  507.   (annotate)
  508.   (vl-cmdf "._zoom"
  509.            (vlax-curve-getstartpoint pline)
  510.            (vlax-curve-getendpoint pline)
  511.   )
  512.   (recvar)
  513.   (timeend)
  514.   (princ)
  515. )
  516.  

Thanks
« Last Edit: March 17, 2019, 07:15:18 AM by Topographer »

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #11 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]
  1.            (initget "1 2")
  2.            (setq
  3.              l
  4.               (cond
  5.                 ((getkword
  6.                    "\nGround 1 (1)/ Ground 2 (2) < 1 > :"
  7.                  )
  8.                 )
  9.                 ("1")
  10.               )
  11.            )
  12.  
  13. (if (eq l "1")
  14.         (COMMAND "_layer" "_m" "Ground1" "_c" "94" "" "")
  15.        )
  16.        (if (eq l "2")
  17.         (COMMAND "_layer" "_m" "Ground2" "_c" "10" "" "")
  18.            )
  19. )
  20.  

The code i use is


Code - Auto/Visual Lisp: [Select]
  1. ;;; CADALYST 09/06  Tip 2149: QuickProfile.lsp  Center Line Profile     (c) 2006 Pedro Ferreira
  2.  
  3.  
  4. ;;;Author: Pedro Miguel da Silva Ferreira       Email:pedro_ferreira@netcabo.pt or pferreira@wsatkins.pt
  5. ;;;Web page: http:pwp.netcabo.pt/pedro_ferreira
  6. ;;;Location: Portugal, Lisboa
  7. ;;;RDS: PMSF
  8. ;;;Command Name: qp
  9. ;;;Date: 09 of May 2006
  10. ;;;Version: 1.0
  11. ;;;Description: Visual Lisp Routine that creates a section profile of the terrain based on the existing contours.
  12. ;;;&#913;&#925;&#913;&#914;&#913;&#920;&#924;&#919;&#931;&#919; 3 &#924;&#913;&#929;&#932;&#921;&#927;&#933; 2019
  13. ;;;Version: 2.0
  14. ;;;TopoCAD
  15.  
  16. (defun timeini ()
  17.   (setq s (getvar "DATE"))
  18.   (setq seconds (* 86400.0 (- s (fix s))))
  19. )
  20.  
  21. (defun timeend ()
  22.   (setq s1 (getvar "DATE"))
  23.   (setq seconds1 (* 86400.0 (- s1 (fix s1))))
  24.   (setq seconds2 (fix (- seconds1 seconds)))
  25.   (princ
  26.     (strcat "\nTime : "
  27.             (itoa seconds2)
  28.             " seconds"
  29.     )
  30.   )
  31. )
  32.  
  33. (defun inivar ()
  34.   (setq cmd_ini (getvar "cmdecho")
  35.         fla_ini (getvar "flatland")
  36.         osm_ini (getvar "osmode")
  37.         ort_ini (getvar "orthomode")
  38.         plt_ini (getvar "plinetype")
  39.         aup_ini (getvar "auprec")
  40.         uni_ini (getvar "unitmode")
  41.         lun_ini (getvar "lunits")
  42.         diz_ini (getvar "dimzin")
  43.         edg_ini (getvar "edgemode")
  44.   )
  45.   (setvar "CMDECHO" 0)
  46.   (setvar "FLATLAND" 0)
  47.   (setvar "OSMODE" 0)
  48.   (setvar "ORTHOMODE" 0)
  49.   (setvar "PLINETYPE" 2)
  50.   (setvar "AUPREC" 0)
  51.   (setvar "UNITMODE" 1)
  52.   (setvar "LUNITS" 2)
  53.   (setvar "DIMZIN" 0)
  54.   (setvar "EDGEMODE" 1)
  55. )
  56.  
  57. (defun recvar ()
  58.   (setvar "CMDECHO" cmd_ini)
  59.   (setvar "FLATLAND" fla_ini)
  60.   (setvar "OSMODE" osm_ini)
  61.   (setvar "ORTHOMODE" ort_ini)
  62.   (setvar "PLINETYPE" plt_ini)
  63.   (setvar "AUPREC" aup_ini)
  64.   (setvar "UNITMODE" uni_ini)
  65.   (setvar "LUNITS" lun_ini)
  66.   (setvar "DIMZIN" diz_ini)
  67.   (setvar "EDGEMODE" edg_ini)
  68. )
  69.  
  70. (defun getlayname ()
  71.   (setq contourstest nil)
  72. ;  (setq        layername
  73. ;        (getstring
  74. ;          "\nPlease enter the layer name of the contours: "
  75. ;        )
  76. ;  )
  77.   (setq contourstest
  78.          (ssget "_x"
  79.                 (list (cons -4 "<OR")
  80.                       (cons -4 "<AND")
  81.                       (cons 0 "lwpolyline")
  82.                       (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
  83.                       (cons -4 "AND>")
  84.                       (cons -4 "<AND")
  85.                       (cons 0 "polyline")
  86.                       (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
  87.                       (cons -4 "AND>")
  88.                       (cons -4 "<AND")
  89.                       (cons 0 "line")
  90.                       (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
  91.                       (cons -4 "AND>")
  92.                       (cons -4 "<AND")
  93.                       (cons 0 "spline")
  94.                       (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
  95.                       (cons -4 "AND>")
  96.                       (cons -4 "OR>")
  97.                 )
  98.          )
  99.   )
  100.  
  101.   (while (= contourstest nil)
  102.     (princ "\n&#916;&#949;&#957; &#949;&#960;&#953;&#955;&#941;&#967;&#952;&#951;&#954;&#945;&#957; &#953;&#963;&#959;&#965;&#968;&#949;&#943;&#962;...")
  103. ;    (setq layername
  104. ;          (getstring
  105. ;            "\nPlease enter the layer name of the contours: "
  106. ;          )
  107. ;    )
  108.     (setq contourstest
  109.            (ssget "_x"
  110.                   (list (cons -4 "<OR")
  111.                         (cons -4 "<AND")
  112.                         (cons 0 "lwpolyline")
  113.                         (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
  114.                         (cons -4 "AND>")
  115.                         (cons -4 "<AND")
  116.                         (cons 0 "polyline")
  117.                         (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
  118.                         (cons -4 "AND>")
  119.                         (cons -4 "<AND")
  120.                         (cons 0 "line")
  121.                         (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
  122.                         (cons -4 "AND>")
  123.                         (cons -4 "<AND")
  124.                         (cons 0 "spline")
  125.                         (cons 8 "Contour Minor Natural Ground,Contour Major Natural Ground")
  126.                         (cons -4 "AND>")
  127.                         (cons -4 "OR>")
  128.                   )
  129.            )
  130.     )
  131.   )
  132. )
  133.  
  134. (defun activexsupport ()
  135.   (setq *modelspace*
  136.          (vla-get-modelspace
  137.          )
  138.   )
  139. )
  140.  
  141. (defun esttexto ()
  142.  
  143.   (vl-cmdf "._style" "PMSF-TEXT" "Arial" 1.8 1 0 "n" "n" "n")
  144. )
  145.  
  146. (defun getha ()
  147.   ;; this entity must be a lwpolyline
  148.   (activexsupport)
  149.   (setq
  150.     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;: ")
  151.   )
  152.   (while (= ha nil)
  153.     (progn
  154.       (princ "\n&#916;&#949;&#957; &#949;&#960;&#953;&#955;&#941;&#967;&#952;&#951;&#954;&#949; &#940;&#958;&#959;&#957;&#945;&#962;...")
  155.       (setq ha
  156.              (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;: ")
  157.       )
  158.     )
  159.   )
  160.   (setq ha-type (cdr (assoc 0 (entget (car ha)))))
  161.   (if (not (equal ha-type "LWPOLYLINE"))
  162.     (progn
  163.       (setq ha nil)
  164.       (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***")
  165.     )
  166.   )
  167.   (while (= ha nil)
  168.     (progn
  169.       (princ "\n&#916;&#949;&#957; &#949;&#960;&#953;&#955;&#941;&#967;&#952;&#951;&#954;&#949; &#940;&#958;&#959;&#957;&#945;&#962;...")
  170.       (setq ha
  171.              (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;: ")
  172.       )
  173.       (setq ha-type (cdr (assoc 0 (entget (car ha)))))
  174.       (if (not (equal ha-type "LWPOLYLINE"))
  175.         (progn
  176.           (setq ha nil)
  177.           (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***")
  178.         )
  179.       )
  180.     )
  181.   )
  182.   (setq ha-ename (entget (car ha)))
  183.   (setq ha-ename (cdr (assoc -1 ha-ename)))
  184.   (setq ha-object (vlax-ename->vla-object ha-ename))
  185.  
  186.   (vl-cmdf "._text"
  187.            (vlax-curve-getstartpoint ha-object)
  188.            "100" ;
  189.            "A"
  190.   )
  191.   (vl-cmdf "._text"
  192.            (vlax-curve-getendpoint ha-object)
  193.            "100" ;
  194.            "B"
  195.   )
  196. )
  197.  
  198. (defun getexaggeration ()
  199.   (initget 2)
  200.   (setq ve (getreal "\n Enter the vertical exaggeration <1>: "))
  201.   (if (= ve nil)
  202.     (setq ve 1)
  203.   )
  204. )
  205.  
  206.  
  207. (defun listptintersect ()
  208.   (setq listaxy nil)
  209.  
  210.   (setq hazvalue (caddr (vlax-curve-getStartPoint ha-object)))
  211.  
  212.   (setq curvas contourstest)
  213.   (setq ncurvas (sslength curvas))
  214.   (setq listaxy nil)
  215.   (setq counter 0)
  216.   (while (< counter ncurvas)
  217.     (progn
  218.       (setq cnivel-ename (ssname curvas counter))
  219.       (setq cnivel-object (vlax-ename->vla-object cnivel-ename))
  220.  
  221.       (setq cnivelzvalue
  222.              (caddr (vlax-curve-getStartPoint cnivel-object))
  223.       )
  224.  
  225.       (setq ha-ENTITY
  226.              (subst (cons 38 cnivelzvalue)
  227.                     (assoc 38 (entget (car ha)))
  228.                     (entget (car ha))
  229.              )
  230.       )
  231.       (entmod ha-ENTITY)
  232.  
  233.       (setq intersectpt
  234.              (vlax-variant-value
  235.                (vlax-invoke-method
  236.                  ha-object
  237.                  "IntersectWith"
  238.                  cnivel-object
  239.                  acExtendNone
  240.                )
  241.              )
  242.       )
  243.  
  244.       (setq test nil)
  245.       (setq
  246.         test (vl-catch-all-apply
  247.                'vlax-safearray->list
  248.                (list intersectpt)
  249.              )
  250.       )
  251.       (setq error (vl-catch-all-error-p test))
  252.  
  253.       (if (/= error t)
  254.         (progn
  255.           (setq intersectpt (vlax-safearray->list intersectpt))
  256.           (setq interlength (length intersectpt))
  257.  
  258.           (if (> interlength 3)
  259.             (progn
  260.               (setq dividelength (/ interlength 3))
  261.               (setq count 0)
  262.               (while (< count interlength)
  263.                 (progn
  264.                   (setq newpt (list (nth count intersectpt)
  265.                                     (nth (+ count 1) intersectpt)
  266.                                     (nth (+ count 2) intersectpt)
  267.                               )
  268.                   )
  269.  
  270.                   (setq x (vlax-curve-getdistatPoint ha-ename newpt))
  271.                   (setq z (caddr intersectpt))
  272.                   (setq xy (list x (* z ve)))
  273.                   (setq
  274.                     listaxy (append listaxy (list xy))
  275.                   )
  276.  
  277.                   (setq count (+ count 3))
  278.                 )
  279.               )
  280.             )
  281.             (progn
  282.               (setq x (vlax-curve-getdistatPoint ha-ename intersectpt))
  283.               (setq z (caddr intersectpt))
  284.               (setq xy (list x (* z ve)))
  285.               (setq
  286.                 listaxy (append listaxy (list xy))
  287.               )
  288.             )
  289.           )
  290.  
  291.           (setq ha-ENTITY
  292.                  (subst (cons 38 hazvalue)
  293.                         (assoc 38 (entget (car ha)))
  294.                         (entget (car ha))
  295.                  )
  296.           )
  297.           (entmod ha-ENTITY)
  298.         )
  299.       )
  300.       (setq counter (1+ counter))
  301.     )
  302.   )
  303.  
  304.   (setq listaxy
  305.          (vl-sort listaxy
  306.                   (function (lambda (e1 e2)
  307.                               (< (car e1) (car e2))
  308.                             )
  309.                   )
  310.          )
  311.   )
  312.  
  313.                     ha-ename
  314.                     (vlax-curve-getstartpoint ha-ename)
  315.                   )
  316.         enddist   (vlax-curve-getdistatPoint
  317.                     ha-ename
  318.                     (vlax-curve-getendpoint ha-ename)
  319.                   )
  320.   )
  321.  
  322.   (setq pt1 (car (car listaxy))
  323.         pt2 (car (last listaxy))
  324.   )
  325.  
  326.   (if (/= startdist pt1)
  327.     (progn
  328.       (setq x startdist)
  329.       (setq y (+ (* (/ (- (cadr (car listaxy)) (cadr (cadr listaxy)))
  330.                        (- (car (cadr listaxy)) (car (car listaxy)))
  331.                     )
  332.                     (- (car (car listaxy)) startdist)
  333.                  )
  334.                  (cadr (car listaxy))
  335.               )
  336.       )
  337.       (setq xy (list x y))
  338.       (setq
  339.         listaxy (append listaxy (list xy))
  340.       )
  341.       (setq listaxy
  342.              (vl-sort listaxy
  343.                       (function (lambda (e1 e2)
  344.                                   (< (car e1) (car e2))
  345.                                 )
  346.                       )
  347.              )
  348.       )
  349.  
  350.     )
  351.   )
  352.  
  353.   (if (/= enddist pt1)
  354.     (progn
  355.       (setq pos (1- (length listaxy)))
  356.       (setq x enddist)
  357.       (setq y
  358.              (+
  359.                (*
  360.                  (/ (- (cadr (nth pos listaxy))
  361.                        (cadr (nth (1- pos) listaxy))
  362.                     )
  363.                     (- (car (nth pos listaxy)) (car (nth (1- pos) listaxy)))
  364.                  )
  365.                  (- enddist (car (nth pos listaxy)))
  366.                )
  367.                (cadr (nth pos listaxy))
  368.              )
  369.       )
  370.       (setq xy (list x y))
  371.       (setq
  372.         listaxy (append listaxy (list xy))
  373.       )
  374.       (setq listaxy
  375.              (vl-sort listaxy
  376.                       (function (lambda (e1 e2)
  377.                                   (< (car e1) (car e2))
  378.                                 )
  379.                       )
  380.              )
  381.       )
  382.  
  383.     )
  384.   )
  385. )
  386.  
  387. (defun createprofile ()
  388. (COMMAND "_layer" "_m" "NATURAL GROUND" "_c" "94" "" "")
  389.   (setq variante-listaxy (apply 'append listaxy))
  390.  
  391.   (setq arraySpace
  392.          (vlax-make-safearray
  393.            vlax-vbdouble
  394.            (cons 0
  395.                  (- (length variante-listaxy) 1)
  396.            )
  397.          )
  398.   )
  399.   (setq variante-listaxy
  400.          (vlax-safearray-fill arraySpace variante-listaxy)
  401.   )
  402.  
  403.   (vlax-make-variant variante-listaxy)
  404.  
  405.  
  406.                 *ModelSpace*
  407.                 variante-listaxy
  408.               )
  409.   )
  410.  
  411.  
  412.   (vl-cmdf "._text"
  413.            (vlax-curve-getstartpoint pline)
  414.            "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
  415.            "A"
  416.   )
  417.   (vl-cmdf "._text"
  418.            (vlax-curve-getendpoint pline)
  419.            "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
  420.            "B"
  421.   )
  422. )
  423.  
  424. (defun annotate ()
  425.   (setq xini (car (vlax-curve-getstartpoint pline))
  426.         xend (car (vlax-curve-getendpoint pline))
  427.         y    (* (fix
  428.                   (/ (cadr (car (vl-sort listaxy
  429.                                          (function (lambda (e1 e2)
  430.                                                      (< (cadr e1) (cadr e2))
  431.                                                    )
  432.                                          )
  433.                                 )
  434.                            )
  435.                      )
  436.                      ve
  437.                   )
  438.                 )
  439.                 ve
  440.              )
  441.   )
  442.   ;;end setq
  443.  
  444.   (if (< y 0)
  445.     (setq y (- y (* 1 ve)))
  446.   )
  447.  
  448.   (setq var-xyini (apply 'append (list (list xini y 0))))
  449.   (setq var-xyend (apply 'append (list (list xend y 0))))
  450.   (createline)
  451.   (COMMAND "_layer" "_m" "REFERENCE" "_c" "7" "" "")
  452.   (setq yref (strcat "H = " (rtos (/ y ve) 2 2) " m"))
  453.   (setq ptloc (list (- xini 30.0) y))
  454.   (vl-cmdf "._text" "_bc" ptloc "100" yref)
  455.  
  456.  
  457.  
  458.  
  459.   (setq lengthlistaxy (length listaxy))
  460.   (setq count 0)
  461.   (while (< count lengthlistaxy)
  462.     (progn
  463.       (setq var-xyini (apply 'append
  464.                              (list (list (car (nth count listaxy))
  465.                                          (cadr (nth count listaxy))
  466.                                          0
  467.                                    )
  468.                              )
  469.                       )
  470.       )
  471.       (setq
  472.         var-xyend (apply 'append
  473.                          (list (list (car (nth count listaxy)) y 0))
  474.                   )
  475.       )
  476.       (createline)
  477.       (COMMAND "_layer" "_m" "elevetion" "_c" "7" "" "")
  478.       (setq ytext (rtos (/ (cadr (nth count listaxy)) ve) 2 2))
  479.       (setq xpt (car (nth count listaxy)))
  480.       (setq xtext (rtos xpt 2 2))  ;CB 11/24/09
  481.       (setq ptloc (list xpt (- y 6.0)))
  482.       (setq ptloc2 (list xpt (- y 54.0))) ;CB 11/24/09
  483.       (vl-cmdf "._text" "_mc" ptloc "0" ytext)
  484.       (COMMAND "_layer" "_m" "DISTANSE" "_c" "7" "" "")
  485.       (vl-cmdf "._text" "_mc" ptloc2 "0" xtext) ;CB 11/24/09
  486.       (setq count (1+ count))
  487.     )
  488.   )
  489.  
  490.  
  491.  
  492.  
  493. )
  494.  
  495.  
  496.  
  497.  
  498.  
  499. (defun createline ()
  500. (COMMAND "_layer" "_m" "lines" "_c" "7" "" "")
  501.   (setq arraySpace
  502.          (vlax-make-safearray
  503.            vlax-vbdouble
  504.            (cons 0
  505.                  (- (length var-xyini) 1)
  506.            )
  507.          )
  508.   )
  509.   (setq var-xyini
  510.          (vlax-safearray-fill arraySpace var-xyini)
  511.   )
  512.  
  513.   (vlax-make-variant var-xyini)
  514.  
  515.   (setq arraySpace
  516.          (vlax-make-safearray
  517.            vlax-vbdouble
  518.            (cons 0
  519.                  (- (length var-xyend) 1)
  520.            )
  521.          )
  522.   )
  523.   (setq var-xyend
  524.          (vlax-safearray-fill arraySpace var-xyend)
  525.   )
  526.  
  527.   (vlax-make-variant var-xyend)
  528.  
  529.   (setq line (vla-addline
  530.                *ModelSpace*
  531.                var-xyini
  532.                var-xyend
  533.              )
  534.   )
  535.  
  536. )
  537.  
  538.  
  539.  
  540.  
  541. (defun c:qp ()
  542.  
  543.   (timeini)
  544.   (inivar)
  545.   (getlayname)
  546.   (esttexto)
  547.   (getha)
  548.   (getexaggeration)
  549.   (listptintersect)
  550.   (createprofile)
  551.   (annotate)
  552.  
  553.   (vl-cmdf "._zoom"
  554.            (vlax-curve-getstartpoint pline)
  555.            (vlax-curve-getendpoint pline)
  556.   )
  557.   (recvar)
  558.   (timeend)
  559.  
  560.  
  561.  (command "setvar" "clayer" "0")
  562.   (princ)
  563. )
  564.  
  565.  

Thanks

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #12 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]
  1. (Defun c:test()
  2. (setvar "OSMODE" 0)
  3.            (initget "1 2")
  4.            (setq
  5.              l
  6.               (cond
  7.                 ((getkword
  8.                    "\nground1 (1)/ &#915;&#953;&#945; ground2 (2) < 1 > :"
  9.                  )
  10.                 )
  11.                 ("1")
  12.               )
  13.            )
  14.  
  15. (if (eq l "1")
  16.         (COMMAND "_layer" "_m" "ground1" "_c" "94" "" "")
  17.        )
  18.        (if (eq l "2")
  19.         (COMMAND "_layer" "_m" "ground2" "_c" "10" "" "")
  20.            )
  21. )
  22. (setq FH (getfiled "select file  L,H (*.txt)" "" "txt" 16))
  23. (setq fil (open FH "r"))
  24. (command "_.pline"); start Polyline
  25. (while (setq lin (read-line fil)) (command lin)); feed in coordinates
  26. (command ""); end Polyline
  27. (setvar "OSMODE" 77)
  28. (command "zoom" "e")
  29. (close fil)
  30. );End Defun
  31.  


pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #13 on: April 01, 2019, 04:58:47 PM »
no one ?  :-(

snownut2

  • Swamp Rat
  • Posts: 971
  • Bricscad 20 Ultimate
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #14 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.

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #15 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
« Last Edit: April 02, 2019, 01:40:51 AM by Topographer »

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #16 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]
  1. (defun ERR (S)
  2.   (if (= S "Function cancelled")
  3.     (princ "\nVERTEXT - cancelled: ")
  4.     (progn (princ "\nVERTEXT - Error: ") (princ S) (terpri))
  5.   )
  6.   (RESETTING)
  7.   (princ "SYSTEM VARIABLES have been reset\n")
  8.   (princ)
  9. )
  10. (defun SETV (SYSTVAR NEWVAL)
  11.   (setq X (read (strcat SYSTVAR "1")))
  12.   (set X (getvar SYSTVAR))
  13.   (setvar SYSTVAR NEWVAL)
  14. )
  15. (defun SETTING ()
  16.   (setq OERR *ERROR*)
  17.   (setq *ERROR* ERR)
  18.   (SETV "CMDECHO" 0)
  19.   (SETV "BLIPMODE" 0)
  20. )
  21. (defun RSETV (SYSTVAR)
  22.   (setq X (read (strcat SYSTVAR "1")))
  23.   (setvar SYSTVAR (eval X))
  24. )
  25.  
  26. (defun RESETTING ()
  27.   (RSETV "CMDECHO")
  28.   (RSETV "BLIPMODE")
  29.   (setq *ERROR* OERR)
  30. )
  31.  
  32.  
  33. (defun DXF (CODE ENAME) (cdr (assoc CODE (entget ENAME)))) ; dxf
  34.  
  35. (defun VERTEXT (/ EN VLIST)
  36.   (setq EN (GET-EN))
  37.   (if (= (DXF 0 EN) "LWPOLYLINE")
  38.     (setq VLIST (GET-LWVLIST EN))
  39.     (setq VLIST (GET-PLVLIST EN))
  40.   )
  41.   (WRITE-IT VLIST EN)
  42. )
  43.  
  44. (defun GET-EN (/ NO-ENT EN MSG1 MSG2)
  45.   (setq NO-ENT 1
  46.         EN     NIL
  47.         MSG1   "\nselect polyline: "
  48.         MSG2   "\nthis is not a polyline !!!."
  49.   )                                     ; setq
  50.   (while NO-ENT
  51.     (setq EN (car (entsel MSG1)))
  52.     (if (and EN
  53.              (or (= (DXF 0 EN) "LWPOLYLINE") (= (DXF 0 EN) "POLYLINE"))
  54.                                         ; or
  55.         )                               ; and
  56.       (progn (setq NO-ENT NIL))         ; progn
  57.       (prompt MSG2)
  58.     )                                   ; if
  59.   )                                     ; while
  60.   EN
  61. )                                       ; get-en
  62.  
  63. (defun GET-LWVLIST (EN / ELIST NUM-VERT VLIST)
  64.   (setq ELIST    (entget EN)
  65.         NUM-VERT (cdr (assoc 90 ELIST))
  66.         ELIST    (member (assoc 10 ELIST) ELIST)
  67.         VLIST    NIL
  68.   )                                     ; setq
  69.   (repeat NUM-VERT
  70.     (setq VLIST (append VLIST (list (cdr (assoc 10 ELIST)))) ; append
  71.     )                                   ; setq
  72.     (setq ELIST (cdr ELIST)
  73.           ELIST (member (assoc 10 ELIST) ELIST)
  74.     )                                   ; setq
  75.   )                                     ; repeat
  76.   VLIST
  77. )                                       ; get-lwvlist
  78.  
  79. (defun GET-PLVLIST (EN / VLIST)
  80.   (setq VLIST NIL
  81.         EN    (entnext EN)
  82.   )                                     ; setq
  83.   (while (/= "SEQEND" (DXF 0 EN))
  84.     (setq VLIST (append VLIST (list (DXF 10 EN))))
  85.     (setq EN (entnext EN))
  86.   )                                     ; while
  87.   VLIST
  88. )                                       ; get-plvlist
  89.  
  90. (defun WRITE-IT (VLST EN / NEWVLIST MSG3 FNAME)
  91.   (setq NEWVLIST (mapcar '(lambda (X) (trans X EN 0)) ;_ lambda
  92.                          VLST
  93.                  ) ;_ mapcar
  94.         MSG3     "Polyline vertex file"
  95.                                         ;FNAME    (getfiled MSG3 "" "txt" 1)
  96.         F1       (open "FNAME" "w")
  97.   )                                     ; setq
  98.   (WRITE-HEADER)
  99.   (WRITE-VERTICES NEWVLIST)
  100.   (setq F1 (close F1))
  101. ) ;_ write-it
  102.  
  103. (defun WRITE-HEADER (/ STR)
  104.   (setq STR "        POLYLINE VERTEX POINTS")
  105.   (write-line STR F1)
  106.   (setq STR (strcat "  X            " "  Y            " "  Z") ;_ strcat
  107.   ) ;_ setq
  108.   (write-line STR F1)
  109. ) ;_ write-header
  110.  
  111.  
  112.  
  113. (defun WRITE-VERTICES (NEWVLIST / XSTR YSTR ZSTR STR l)
  114.    (setvar 'OSMODE  0)
  115.            (initget "1 2")
  116.            (setq
  117.              l
  118.               (cond
  119.                 ((getkword
  120.                    "\nfor Ground 1 (1)/ for ground 2 (2) < 1 > :"
  121.                  )
  122.                 )
  123.                 ("1")
  124.               )
  125.            )
  126.        
  127. (if (eq l "1")
  128.         (COMMAND "_layer" "_m" "ground1" "_c" "94" "" "")
  129.        )
  130.        (if (eq l "2")
  131.         (COMMAND "_layer" "_m" "ground2" "_c" "10" "" "")
  132.            )
  133. )
  134.   (setq httt "2")
  135.   (setq gptx (getpoint "\nPick a point to insert length text: "))
  136.   (setq gpty (getpoint "\nPick a point to insert elevetion text: "))
  137.   (foreach ITEM NEWVLIST
  138.     (setq XSTR (rtos (nth 0 (/ ITEM ve)) 2 2)
  139.           YSTR (rtos (nth 1 ITEM) 2 2)
  140.           ZSTR (rtos (nth 2 ITEM) 2 2)
  141.           STR  (strcat XSTR (SPACES XSTR) YSTR (SPACES YSTR) ZSTR) ;_ strcat
  142.     )                                   ; setq
  143.                                         ;      (write-line STR F1)
  144.  
  145.  (command "._style" "PMSF-TEXT" "Arial" 1.8 1 0 "n" "n" "n")
  146.     (command "text"
  147.              (list (+ (atof xstr) (/ (atof httt) 2.0)) (cadr gptx))
  148.              httt
  149.              "0"
  150.              (strcat xstr)
  151.     )
  152.     (command "text"
  153.              (list (+ (atof xstr) (/ (atof httt) 2.0)) (cadr gpty))
  154.              httt
  155.              "0"
  156.              (strcat ystr)
  157.     )
  158.  
  159.   )                                     ; foreach
  160.  
  161. )                                       ; write-vertices
  162.  
  163.  
  164. (defun SPACES (STR / FIELD NUM CHAR SPACE)
  165.   (setq FIELD 15
  166.         NUM   (- FIELD (strlen STR))
  167.         CHAR  " "
  168.         SPACE ""
  169.   ) ;_ setq
  170.   (repeat NUM (setq SPACE (strcat SPACE CHAR))) ;_ repeat
  171. ) ;_ spaces
  172.  
  173. (defun C:vd2 () (SETTING) (VERTEXT) (RESETTING) (princ)) ; c:nsl
  174.  
  175.  

Thanks

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #17 on: April 03, 2019, 02:47:32 PM »
no one ?  :-(

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #18 on: April 04, 2019, 10:05:47 AM »
it is important .Can anyone help  ?:-(

Thanks

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #19 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]
  1.  
  2. (defun ERR (S)
  3.   (if (= S "Function cancelled")
  4.     (princ "\nVERTEXT - cancelled: ")
  5.     (progn (princ "\nVERTEXT - Error: ") (princ S) (terpri))
  6.   )
  7.   (RESETTING)
  8.   (princ "SYSTEM VARIABLES have been reset\n")
  9.   (princ)
  10. )
  11. (defun SETV (SYSTVAR NEWVAL)
  12.   (setq X (read (strcat SYSTVAR "1")))
  13.   (set X (getvar SYSTVAR))
  14.   (setvar SYSTVAR NEWVAL)
  15. )
  16. (defun SETTING ()
  17.   (setq OERR *ERROR*)
  18.   (setq *ERROR* ERR)
  19.   (SETV "CMDECHO" 0)
  20.   (SETV "BLIPMODE" 0)
  21. )
  22. (defun RSETV (SYSTVAR)
  23.   (setq X (read (strcat SYSTVAR "1")))
  24.   (setvar SYSTVAR (eval X))
  25. )
  26.  
  27. (defun RESETTING ()
  28.   (RSETV "CMDECHO")
  29.   (RSETV "BLIPMODE")
  30.   (setq *ERROR* OERR)
  31. )
  32.  
  33.  
  34. (defun DXF (CODE ENAME) (cdr (assoc CODE (entget ENAME)))) ; dxf
  35.  
  36. (defun VERTEXT (/ EN VLIST)
  37.   (setq EN (GET-EN))
  38.   (if (= (DXF 0 EN) "LWPOLYLINE")
  39.     (setq VLIST (GET-LWVLIST EN))
  40.     (setq VLIST (GET-PLVLIST EN))
  41.   )
  42.   (WRITE-IT VLIST EN)
  43. )
  44.  
  45. (defun GET-EN (/ NO-ENT EN MSG1 MSG2)
  46.   (setq NO-ENT 1
  47.         EN     NIL
  48.         MSG1   "\nSelect a polyline: "
  49.         MSG2   "\nNo polyline selected, try again."
  50.   )                                     ; setq
  51.   (while NO-ENT
  52.     (setq EN (car (entsel MSG1)))
  53.     (if (and EN
  54.              (or (= (DXF 0 EN) "LWPOLYLINE") (= (DXF 0 EN) "POLYLINE"))
  55.                                         ; or
  56.         )                               ; and
  57.       (progn (setq NO-ENT NIL))         ; progn
  58.       (prompt MSG2)
  59.     )                                   ; if
  60.   )                                     ; while
  61.   EN
  62. )                                       ; get-en
  63.  
  64. (defun GET-LWVLIST (EN / ELIST NUM-VERT VLIST)
  65.   (setq ELIST    (entget EN)
  66.         NUM-VERT (cdr (assoc 90 ELIST))
  67.         ELIST    (member (assoc 10 ELIST) ELIST)
  68.         VLIST    NIL
  69.   )                                     ; setq
  70.   (repeat NUM-VERT
  71.     (setq VLIST (append VLIST (list (cdr (assoc 10 ELIST)))) ; append
  72.     )                                   ; setq
  73.     (setq ELIST (cdr ELIST)
  74.           ELIST (member (assoc 10 ELIST) ELIST)
  75.     )                                   ; setq
  76.   )                                     ; repeat
  77.   VLIST
  78. )                                       ; get-lwvlist
  79.  
  80. (defun GET-PLVLIST (EN / VLIST)
  81.   (setq VLIST NIL
  82.         EN    (entnext EN)
  83.   )                                     ; setq
  84.   (while (/= "SEQEND" (DXF 0 EN))
  85.     (setq VLIST (append VLIST (list (DXF 10 EN))))
  86.     (setq EN (entnext EN))
  87.   )                                     ; while
  88.   VLIST
  89. )                                       ; get-plvlist
  90.  
  91. (defun WRITE-IT (VLST EN / NEWVLIST MSG3 FNAME)
  92.   (setq NEWVLIST (mapcar '(lambda (X) (trans X EN 0)) ;_ lambda
  93.                          VLST
  94.                  ) ;_ mapcar
  95.         MSG3     "Polyline vertex file"
  96.                                         ;FNAME    (getfiled MSG3 "" "txt" 1)
  97.         F1       (open "FNAME" "w")
  98.   )                                     ; setq
  99.   (WRITE-HEADER)
  100.   (WRITE-VERTICES NEWVLIST)
  101.   (setq F1 (close F1))
  102. ) ;_ write-it
  103.  
  104. (defun WRITE-HEADER (/ STR)
  105.   (setq STR "        POLYLINE VERTEX POINTS")
  106.   (write-line STR F1)
  107.   (setq STR (strcat "  X            " "  Y            " "  Z") ;_ strcat
  108.   ) ;_ setq
  109.   (write-line STR F1)
  110. ) ;_ write-header
  111.  
  112.  
  113. (defun WRITE-VERTICES (NEWVLIST / XSTR YSTR ZSTR STR)
  114.   (setq httt "0.3")
  115.   (setq gptx (getpoint "\nBasepoint for X axis: "))
  116.   (setq gpty (getpoint "\nBasepoint for Y axis: "))
  117.  
  118.   (foreach ITEM NEWVLIST
  119.     (setq XSTR (rtos (nth 0 ITEM) 2 2)
  120.           YSTR (rtos (/ (nth 1 ITEM) 10) 2 2)
  121.           ZSTR (rtos (nth 2 ITEM) 2 2)
  122.           STR  (strcat XSTR (SPACES XSTR) YSTR (SPACES YSTR) ZSTR) ;_ strcat
  123.     )                                   ; setq
  124.                                         ;      (write-line STR F1)
  125.  
  126.  
  127.  
  128.     (command "text"
  129.              (list (+ (atof xstr) (/ (atof httt) 2.0)) (cadr gptx))
  130.              httt
  131.              "0"
  132.              (strcat xstr)
  133.     )
  134.     (command "text"
  135.              (list (+ (atof xstr) (/ (atof httt) 2.0)) (cadr gpty))
  136.              httt
  137.              "0"
  138.              (strcat ystr)
  139.     )
  140.  
  141.   )                                     ; foreach
  142.  
  143. )                                       ; write-vertices
  144.  
  145.  
  146. (defun SPACES (STR / FIELD NUM CHAR SPACE)
  147.   (setq FIELD 15
  148.         NUM   (- FIELD (strlen STR))
  149.         CHAR  " "
  150.         SPACE ""
  151.   ) ;_ setq
  152.   (repeat NUM (setq SPACE (strcat SPACE CHAR))) ;_ repeat
  153. ) ;_ spaces
  154.  
  155. (defun C:vv () (SETTING) (VERTEXT) (RESETTING) (princ)) ; c:nsl
  156.  
  157. (prompt "\nwritten by ENGR..Mr.Muhammad USMAN SOHAIL #03008342153")
  158. (prompt "\nEnter VV to start")
  159.  
  160.  

Thanks

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #20 on: April 07, 2019, 12:54:48 PM »
i find it .
Thanks

pedroantonio

  • Guest
Re: QUICK PROFILE LISP- hELP WITH UPDATE
« Reply #21 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]
  1.  
  2. (defun ERR (S)
  3.   (if (= S "Function cancelled")
  4.     (princ "\nVERTEXT - cancelled: ")
  5.     (progn (princ "\nVERTEXT - Error: ") (princ S) (terpri))
  6.   )
  7.   (RESETTING)
  8.   (princ "SYSTEM VARIABLES have been reset\n")
  9.   (princ)
  10. )
  11. (defun SETV (SYSTVAR NEWVAL)
  12.   (setq X (read (strcat SYSTVAR "1")))
  13.   (set X (getvar SYSTVAR))
  14.   (setvar SYSTVAR NEWVAL)
  15. )
  16. (defun SETTING ()
  17.   (setq OERR *ERROR*)
  18.   (setq *ERROR* ERR)
  19.   (SETV "CMDECHO" 0)
  20.   (SETV "BLIPMODE" 0)
  21. )
  22. (defun RSETV (SYSTVAR)
  23.   (setq X (read (strcat SYSTVAR "1")))
  24.   (setvar SYSTVAR (eval X))
  25. )
  26.  
  27. (defun RESETTING ()
  28.   (RSETV "CMDECHO")
  29.   (RSETV "BLIPMODE")
  30.   (setq *ERROR* OERR)
  31. )
  32.  
  33.  
  34. (defun DXF (CODE ENAME) (cdr (assoc CODE (entget ENAME)))) ; dxf
  35.  
  36. (defun VERTEXT (/ EN VLIST)
  37.   (setq EN (GET-EN))
  38.   (if (= (DXF 0 EN) "LWPOLYLINE")
  39.     (setq VLIST (GET-LWVLIST EN))
  40.     (setq VLIST (GET-PLVLIST EN))
  41.   )
  42.   (WRITE-IT VLIST EN)
  43. )
  44.  
  45. (defun GET-EN (/ NO-ENT EN MSG1 MSG2)
  46.   (setq NO-ENT 1
  47.         EN     NIL
  48.         MSG1   "\nSelect a polyline: "
  49.         MSG2   "\nNo polyline selected, try again."
  50.   )                                     ; setq
  51.   (while NO-ENT
  52.     (setq EN (car (entsel MSG1)))
  53.     (if (and EN
  54.              (or (= (DXF 0 EN) "LWPOLYLINE") (= (DXF 0 EN) "POLYLINE"))
  55.                                         ; or
  56.         )                               ; and
  57.       (progn (setq NO-ENT NIL))         ; progn
  58.       (prompt MSG2)
  59.     )                                   ; if
  60.   )                                     ; while
  61.   EN
  62. )                                       ; get-en
  63.  
  64. (defun GET-LWVLIST (EN / ELIST NUM-VERT VLIST)
  65.   (setq ELIST    (entget EN)
  66.         NUM-VERT (cdr (assoc 90 ELIST))
  67.         ELIST    (member (assoc 10 ELIST) ELIST)
  68.         VLIST    NIL
  69.   )                                     ; setq
  70.   (repeat NUM-VERT
  71.     (setq VLIST (append VLIST (list (cdr (assoc 10 ELIST)))) ; append
  72.     )                                   ; setq
  73.     (setq ELIST (cdr ELIST)
  74.           ELIST (member (assoc 10 ELIST) ELIST)
  75.     )                                   ; setq
  76.   )                                     ; repeat
  77.   VLIST
  78. )                                       ; get-lwvlist
  79.  
  80. (defun GET-PLVLIST (EN / VLIST)
  81.   (setq VLIST NIL
  82.         EN    (entnext EN)
  83.   )                                     ; setq
  84.   (while (/= "SEQEND" (DXF 0 EN))
  85.     (setq VLIST (append VLIST (list (DXF 10 EN))))
  86.     (setq EN (entnext EN))
  87.   )                                     ; while
  88.   VLIST
  89. )                                       ; get-plvlist
  90.  
  91. (defun WRITE-IT (VLST EN / NEWVLIST MSG3 FNAME)
  92.   (setq NEWVLIST (mapcar '(lambda (X) (trans X EN 0)) ;_ lambda
  93.                          VLST
  94.                  ) ;_ mapcar
  95.         MSG3     "Polyline vertex file"
  96.                                         ;FNAME    (getfiled MSG3 "" "txt" 1)
  97.         F1       (open "FNAME" "w")
  98.   )                                     ; setq
  99.   (WRITE-HEADER)
  100.   (WRITE-VERTICES NEWVLIST)
  101.   (setq F1 (close F1))
  102. ) ;_ write-it
  103.  
  104. (defun WRITE-HEADER (/ STR)
  105.   (setq STR "        POLYLINE VERTEX POINTS")
  106.   (write-line STR F1)
  107.   (setq STR (strcat "  X            " "  Y            " "  Z") ;_ strcat
  108.   ) ;_ setq
  109.   (write-line STR F1)
  110. ) ;_ write-header
  111.  
  112.  
  113. (defun WRITE-VERTICES (NEWVLIST / XSTR YSTR ZSTR STR)
  114.    (setvar 'OSMODE 64)
  115.            (initget "1 2")
  116.            (setq
  117.              l
  118.               (cond
  119.                 (