I have a code that labels the ex grade and the pipe ie. Most of this code was something i found on the net. The code ask the user to pick the base elevation, the profile, the label start and end location, and to mirror or move the label. It is all working but for some reason the elevations are not correct, I think the error is happening in the vlax-curve-getclosestpointto function. I have been working on this 1.5 weeks now have have not had any luck fixing or finding another way to do this. See the cad file and run the command ppl for more info. Please help, Thanks!
;PPL COMMAND THIS CODE WILL LABLE THE EXISTING AND IE ALONG THE PROFILE
;;load ActiveX library
(vl-load-com)
;;// FUNCTIONS
(defun start (curve)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
(vlax-curve-getstartpoint curve
)
)
)
)
)
)
;;//
(defun end (curve)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
(vlax-curve-getendpoint curve
)
)
)
)
)
)
;;//
(defun pointoncurve (curve pt)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
pt
)
)
)
)
)
;;//
(defun paramatpoint (curve pt)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getparamatpoint curve
pt
)
)
)
)
)
;;//
(defun distatpt (curve pt)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getdistatpoint curve
(vlax-curve-getclosestpointto curve pt)
)
)
)
)
)
;;//
(defun pointatdist (curve dist)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getclosestpointto curve
(vlax-curve-getpointatdist curve dist)
)
)
)
)
)
;;//
(defun curvelength (curve)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getdistatparam curve
(- (vlax-curve-getendparam curve)
(vlax-curve-getstartparam curve)
)
)
)
)
)
)
;;//
(defun distatparam (curve param)
(vl-catch-all-apply (function (lambda()
(vlax-curve-getdistatparam curve
param
)
)
)
)
)
;;//
(defun statlabel (num step div)
;; num - integer, zero based
;; step - double or integer, must be non zero
(strcat
(itoa (fix (/ num div)))
"+"
(if (zerop (rem num div))
"00"
(rtos (* (rem num div) step) 2 0))
)
)
;;//
(defun gettangent (curve pt)
(setq param (paramatpoint curve pt)
ang ((lambda (deriv)
(if (zerop (cadr deriv))
(/ pi 2)
(atan (apply '/ deriv))
)
)
(cdr (reverse
(vlax-curve-getfirstderiv curve param)
)
)
)
)
ang
)
;; Error Handling Function
(defun PPL_Error (msg)
(command)
(command "undo" "end")
;(vla-endundomark adoc)
(command "u")
(setvar "OSMODE" OM)
(setvar "orthomode" ORTHO)
(setvar "nomutt" 0);Sets command line to on / on(0)off(1)
(setvar "cmdecho" CMD)
(setq *error* OriginalErrorHandling)
(prompt "\nProgram Error: ")
(princ)
)
;;---------------------- main program -----------------------------;;
(defun c:PPL (/ *error* acdoc acsp adoc cnt dia div dlev dp eltext grad grcoords lay leng lp num osm plev pp prof pt ptlist
rot rp startleng startpt step tline tlinept txt x zero)
(vl-load-com)
(setq OriginalErrorHandling *error*)
(setq *error* PPL_Error)
(setq cmd (getvar "cmdecho"));Saves current command echo settings
(setvar "cmdecho" 0);Sets command echo to off on(1) off(2)
(command "undo" "begin")
(setq cmd (getvar "cmdecho"));Saves current command echo settings
(command "ucs" "save" "PPL")
(command "ucs" "")
(setq OM (getvar "OSMODE"));Saves current osnap settings
(setq ORTHO (getvar "orthomode"));Saves current or the settings
;(setvar "orthomode" 0);Sets ortho to off on(1) off(0)
(setq adoc (vla-get-activedocument (vlax-get-acad-object))acsp (vla-get-block (vla-get-activelayout adoc)))
;(vla-startundomark adoc)
(setvar "dimzin" 2)
(setq lay (getvar "clayer"));Saves current layer
(setq layc (getvar "cecolor"));Saves current color
(setvar "clayer" "0");Sets current layer
(setvar "cecolor" "3");Sets current color
(setq *step* 50)
(setq *dia* 150)
(if
(and
(setvar "nomutt" 0)
(or (initget 6)
(setq step (getreal (strcat "\nEnter the station interval <" (rtos *step* 2 0) "> : ")))
(cond ((not step)(setq step *step*)))
(setq *step* step))
)
(and
(setvar "nomutt" 0)
(or (initget 6)
(setq dia (getreal (strcat "\nEnter the pipe diameter, mm <" (rtos *dia* 2 0) "> : ")))
(cond ((not dia)(setq dia *dia*)))
(setq *dia* dia))
)
)
(progn
(princ "\nSelect profile base elevation (lower left text): ")
(while (null (setq eltext (ssget ":S:E" (list (cons 0 "*text")(cons 8 "C-ROAD-PROF-TEXT"))))));Get text from user for base elevation CODE WILL NOT CONTINUE UNTILL SELECTION IS MADE
(setvar "OSMODE" 1);Sets osnap to endpoint
(prompt "\nSelect Lower left and upper right corners of profile:")
(setq p1 (getpoint "\nSpecify first corner: "));Get point from user to use (ssget "W" P1 P2
(setq p2 (getcorner p1 "\nSpecify opposite corner: "));Get point from user to use (ssget "W" P1 P2
(prompt "\nSelect first and last lable location:")
(setq lp1 (getpoint "\nSpecify first text location: "));Get point from user to use (ssget "W" P1 P2
(setq lp2 (getpoint "\nSpecify last text location: "))
(command "line" lp1 lp2 "")
(setq tline (ssget "_l"))
(setvar "OSMODE" OM)
(setq PL (ssget "W" P1 P2 '((8 . "C-ROAD-PROF-TITL,C-ROAD-PROF-TITL-PATT"))));Finds objects in the window applying the filter selection
(setq ML(getstring "\nDo you want to mirror profile label? No/<Yes>:"));Sets variable from user
(if (= ML "")(command "._mirror" PL "" "_non" (setq cent (mapcar '*(mapcar '+ P1 P2)'(0.5 0.5 0.5)))"_non" (polar cent 0.0 1.0)"yes"));mirror object from MP
(if (= ML "y")(command "._mirror" PL "" "_non" (setq cent (mapcar '*(mapcar '+ P1 P2)'(0.5 0.5 0.5)))"_non" (polar cent 0.0 1.0)"yes"))
(if (= ML "yes")(command "._mirror" PL "" "_non" (setq cent (mapcar '*(mapcar '+ P1 P2)'(0.5 0.5 0.5)))"_non" (polar cent 0.0 1.0)"yes"))
(if (= ML "Y")(command "._mirror" PL "" "_non" (setq cent (mapcar '*(mapcar '+ P1 P2)'(0.5 0.5 0.5)))"_non" (polar cent 0.0 1.0)"yes"))
(if (= ML "YES")(command "._mirror" PL "" "_non" (setq cent (mapcar '*(mapcar '+ P1 P2)'(0.5 0.5 0.5)))"_non" (polar cent 0.0 1.0)"yes"))
(setq grad (ssget "W" P1 P2 (list (cons 0 "lwpolyline")(cons 8 "C-ROAD-PROF"))));selects the gradeline
(setq prof (ssget "W" P1 P2 (list (cons 0 "lwpolyline")(cons 8 "C-SSWR-FORC"))));selects the forcemain line
(setvar "nomutt" 0)
(setq grad (ssname grad 0))
(setq prof (ssname prof 0))
(setq tline (ssname tline 0))
(setq eltext (ssname eltext 0))
(setq grcoords (vl-remove-if 'not (mapcar '(lambda (x)(if (= 10 (car x))(cdr x)))(entget grad))))
(setq startpt (trans (car (vl-remove-if '(lambda (x)(< (car a)(car b)))grcoords)) 0 1))
(setq tlinept (pointoncurve tline startpt)
startleng (distatparam
tline
(vlax-curve-getparamatpoint tline tlinept))
leng (- (distatparam tline (vlax-curve-getendparam tline))
startleng)
num (fix (/ leng step))
div (fix (/ 100. step))
)
(setvar "clayer" "C-ROAD-PROF-TEXT")
(setvar "cecolor" "bylayer")
(setq cnt 0)
(repeat (1+ num)
(setq pt (polar (pointatdist tline startleng) (* pi 1.5) 1.75)
rot 0.0
ptlist (cons pt ptlist)
)
;REMOVE COMMENTS BELOW TO ADD STATION #S
;(setq txt (vla-addtext acsp (statlabel cnt step div) (vlax-3d-point pt) 3.5))
;(vla-put-alignment txt acAlignmentTopCenter)
;(vla-put-textalignmentpoint txt (vlax-3d-point pt))
;(vla-put-rotation txt rot)
;(vla-put-stylename txt "HGBD-OPTI1-MS" )
(setq cnt (1+ cnt)
startleng (+ startleng step))
)
;;---------------------------------------------;;
(setq ptlist (reverse ptlist))
(setq zero (atof(vla-get-textstring (vlax-ename->vla-object eltext))))
(foreach p ptlist
(setq lp (polar p (* pi 0.75) 2.47)
rp (polar p (/ pi 4) 2.47))
(setq dp (vlax-curve-getclosestpointto grad p)
pp (vlax-curve-getclosestpointto prof p))
(setq dlev (cadr dp)
plev (cadr pp))
(setq txt (vla-addtext acsp (strcat "E.G. EL="(rtos (+ zero (/ (- dlev(cadr tlinept) ) 10.)) 2 2)) (vlax-3d-point lp) 2.54))
(vla-put-alignment txt acAlignmentMiddleLeft )
(vla-put-textalignmentpoint txt (vlax-3d-point lp))
(vla-put-rotation txt (/ pi 2))
(vla-put-color txt acred)
(vla-put-stylename txt "HGBD-OPTI1-MS" )
(setq txt (vla-addtext acsp (strcat "PIPE I.E.="(rtos (+ zero (- (/ (- plev (cadr tlinept) ) 10.) (/ (/ dia 1000.) 2))) 2 2)) (vlax-3d-point rp) 2.54))
(vla-put-alignment txt acAlignmentMiddleLeft )
(vla-put-textalignmentpoint txt (vlax-3d-point rp))
(vla-put-rotation txt (/ pi 2))
(vla-put-color txt acyellow)
(vla-put-stylename txt "HGBD-OPTI1-MS" )
)
)
(command "erase" tline "")
(setvar "orthomode" 1);Sets ortho to off on(1) off(0)
(setq ML(getstring "\nDo you want to move profile label? Yes/<No>:"));Sets variable from user
(if (= ML "") "" "");If user
(if (= ML "y")(command "._move" PL "" pause pause))
(if (= ML "yes")(command "._move" PL "" pause pause))
(if (= ML "Y")(command "._move" PL "" pause pause))
(if (= ML "YES")(command "._move" PL "" pause pause))
(setvar "clayer" lay)
(setvar "cecolor" layc)
(command "ucs" "restore" "PPL")
(command "ucs" "delete" "PPL")
(command "undo" "end")
(setvar "cmdecho" CMD)
(princ)
)
