需要专业帮助
伙计们我是autolisp的新手，有人能帮我编辑这段代码吗。我想将输出从多段线更改为样条线，并按50米进行标记。
(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)
)
页:
[1]