Jump to content

Need professional help


hctub

Recommended Posts

Guys

 

Im a newbie in autolisp can someone help me to edit this code. I want to change the output from polyline to spline and labeled as per 50 meters.

 

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

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

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

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

(defun getlayname ()
 (setq contourstest nil)
 (setq    layername
    (getstring
      "\nPlease enter the layer name of the contours: "
    )
 )
 (setq    contourstest
    (ssget    "_x"
       (list (cons -4 "<OR")
             (cons -4 "<AND")
             (cons 0 "lwpolyline")
             (cons 8 layername)
             (cons -4 "AND>")
             (cons -4 "<AND")
             (cons 0 "polyline")
             (cons 8 layername)
             (cons -4 "AND>")
             (cons -4 "<AND")
             (cons 0 "line")
             (cons 8 layername)
             (cons -4 "AND>")
             (cons -4 "<AND")
             (cons 0 "spline")
             (cons 8 layername)
             (cons -4 "AND>")
             (cons -4 "OR>")
       )
    )
 )

 (while (= contourstest nil)
   (princ "\nNo contours selected...")
   (setq layername
      (getstring
        "\nPlease enter the layer name of the contours: "
      )
   )
   (setq contourstest
      (ssget "_x"
         (list    (cons -4 "<OR")
           (cons -4 "<AND")
           (cons 0 "lwpolyline")
           (cons 8 layername)
           (cons -4 "AND>")
           (cons -4 "<AND")
           (cons 0 "polyline")
           (cons 8 layername)
           (cons -4 "AND>")
           (cons -4 "<AND")
           (cons 0 "line")
           (cons 8 layername)
           (cons -4 "AND>")
           (cons -4 "<AND")
           (cons 0 "spline")
           (cons 8 layername)
           (cons -4 "AND>")
           (cons -4 "OR>")
         )
      )
   )
 )
)

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

(defun esttexto    ()

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

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

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

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


(defun listptintersect ()
 (setq listaxy nil)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   )
 )

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

   )
 )
)

(defun createprofile ()
 (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 spline (vla-addLightweightPolyline
       *ModelSpace*
       variante-listaxy
         )
 )


 (vl-cmdf "._text"
      (vlax-curve-getstartpoint spline)
      "0"
      "A"
 )
 (vl-cmdf "._text"
      (vlax-curve-getendpoint spline)
      "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)
 (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)

     (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)
     (vl-cmdf "._text" ptloc2 "90" xtext);;CB 11/24/09

     (setq count (1+ count))
   )
 )




)



(defun createline ()

 (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
        )
 )

)
;;-----------------------------------------------------
;;print chainage and elevs to drawing CAB 11/20/09
(defun print_table ()
 (initget 1)
 (setq TabInsPt (getpoint "\nPick upper left table location: "))
 (setq Tab_lbl1 "%HAINAGE")
 (command "._text" TabInsPt 0.0 Tab_lbl1)
 (setq TxtLen (caadr (textbox (entget (entlast)))))
 (setq Pt2 (list (+ (car TabInsPt) txtlen (cdr (assoc 40 (entget (entlast))))) (cadr TabInsPt))) 
 (foreach ch_val listaxy
    (setq sta (rtos (car ch_val) 2 2))
    (command "._text" "" sta)
 )
 (command "._text" Pt2 0.0 "%LEVATION")
 (foreach ch_val listaxy
    (setq elev (rtos (cadr ch_val) 2 2))
    (command "._text" "" elev)
 )
 
)
;;--------------------------------------------------
(defun c:qp ()
 (timeini)
 (inivar)
 (getlayname)
 (esttexto)
 (getha)
 (getexaggeration)
 (listptintersect)
 (createprofile)
 (annotate)
 ;;;(print_table);;11/20/09

 (vl-cmdf "._zoom"
      (vlax-curve-getstartpoint pline)
      (vlax-curve-getendpoint pline)
 )
 (recvar)
 (timeend)
 (princ)
)

Edited by Tiger
added codetags
Link to comment
Share on other sites

Join the conversation

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

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

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

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

×   Your previous content has been restored.   Clear editor

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

×
×
  • Create New...