【求助】下面网址中的程序有问题，可否帮忙修改一下
https://lispbox.wordpress.com//?s=centerpline.lsp&search=Gocenterpline.lsp
;;;************************ centerPline.LSP ***********************;;;
;;; ;;;
;;; Centerline between two polyline ;;;
;;; ;;;
;;; author: Gian Paolo Cattaneo ;;;
;;; ;;;
;;; version: 1.0 - 21.12.2013 ;;;
;;; ;;;
;;;****************************************************************;;;
(defun c:CPL ( / *error* Loft_n Loft_p Loft_u Loft_v :e1 :e2
e1 e2 p1 p2 D_off EL e1o e2o L1 L2 EL1 E_new
*pl* E_join pa pb e_del results rip)
(defun *error* ( msg )
(command "_.undo" "_end")
(if Loft_n (setvar 'loftnormals Loft_n))
(if Loft_p (setvar 'loftparam Loft_p))
(if Loft_u (setvar 'surfu Loft_u))
(if Loft_v (setvar 'surfv Loft_v))
(if pl_type (setvar 'plinetype pl_type))
(setvar 'cmdecho cmd)
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(if (null ETmsg) (check_ET))
(check_ucs)
(check_view)
(check_ver)
(setq Loft_n (getvar 'loftnormals))
(setq Loft_p (getvar 'loftparam))
(setq Loft_u (getvar 'surfu))
(setq Loft_v (getvar 'surfv))
(setq pl_type (getvar 'plinetype))
(setvar 'loftnormals 0)
(setvar 'loftparam 7)
(setvar 'surfu 0)
(setvar 'surfv 0)
(if (= 0 (getvar 'plinetype)) (setvar 'plinetype 1))
(if (and
(setq :e1 ( "\nSelect First Polyline"))
(setq p1 (cadr :e1))
(setq :e1 (car :e1))
(not (redraw :e1 3))
(setq :e2 ( "\nSelect Second Polyline"))
(setq p2 (cadr :e2))
(setq :e2 (car :e2))
)
(progn
(redraw :e1 4)
(check_elev)
(check_normal)
(setq e1 (entmakex (cdr (entget :e1))))
(setq e2 (entmakex (cdr (entget :e2))))
(setq D_off (* (Max (MaxDist e1 e2) (MaxDist e2 e1)) 0.53))
(setq EL (entlast))
(command "_offset" D_off e1 "_non" p2 "")
(setq e1o (entlast))
(check_offset)
(setq EL (entlast))
(command "_offset" D_off e2 "_non" p1 "")
(setq e2o (entlast))
(check_offset)
(command "_move" e1o e2o "" "_non" "0,0,0" "_non" (list 0.0 0.0 (* D_off 0.5)))
(command "_loft" e1 e1o "" "")
(setq L1 (entlast))
(command "_loft" e2 e2o "" "")
(setq L2 (entlast))
(setq EL (entlast) EL1 EL)
(command "_intersect" L1 L2 "")
(mapcar
'(lambda (x)
(if (not (vlax-erased-p x)) (entdel x))
)
(list e1o e2o e1 e2 L1 L2)
)
(if (> (sslength (setq E_new (e_next EL "SS"))) 0)
(progn
(if :ET:
(acet-flatn E_new nil)
(progn
(command "_move" E_new "" "_non" "0,0,0" "_non" "0,0,1e99")
(command "_move" E_new "" "_non" "0,0,0" "_non" "0,0,-1e99")
)
)
(setq E_join (e_next EL1 "LS"))
(if (= "LINE" (cdr (assoc 0 (entget (car E_join)))))
(progn
(setq pa (trans (cdr (assoc 10 (entget (car E_join)))) 0 1))
(setq pb (trans (cdr (assoc 11 (entget (car E_join)))) 0 1))
(command "_pline" "_non" pa "_non" pb "")
(setq E_join (subst (entlast) (setq e_del (car E_join)) E_join))
(entdel e_del)
)
)
(command "_.join")
(apply 'command E_join)
(command "")
(setq results t)
)
)
)
)
(setvar 'loftnormals Loft_n)
(setvar 'loftparam Loft_p)
(setvar 'surfu Loft_u)
(setvar 'surfv Loft_v)
(setvar 'plinetype pl_type)
(command "_.undo" "_end")
(setvar 'cmdecho cmd)
(prompt "\n ") (prompt "\n ")(prompt "\n ")
(if results (prompt (strcat "\nCenterline created " (if :ET: "(Polyline)." "(Spline)."))))
(princ)
)
;****************************************************************************
(defun check_ET ()
(if (member "acetutil.arx" (arx))
(progn
(or acet-flatn (load "FLATTENSUP.LSP"))
(setq :ET: t)
)
(progn
(setq :ET: nil)
(alert
(strcat
"Express Tools are not installed."
"\nIf there are curves the centerline is drawn with a spline."
)
)
(setq ETmsg t)
)
)
)
;****************************************************************************
(defun check_ucs ()
(or
(and
(zerop (caddr (getvar 'ucsxdir)))
(zerop (caddr (getvar 'ucsydir)))
)
(progn
(alert "UCS not normal to the WCS")
(exit)
)
)
)
;****************************************************************************
(defun check_view ()
(or
(and
(zerop (car (getvar 'viewdir)))
(zerop (cadr (getvar 'viewdir)))
(> (caddr (getvar 'viewdir)) 0)
)
(progn
(alert "View needs to be in plan (0 0 1)")
(exit)
)
)
)
;****************************************************************************
(defun check_ver ()
(if (< (atoi (substr (ver) 13)) 2011)
(progn
(alert "This routine require AutoCAD 2011 or higher.")
(exit)
)
)
)
;****************************************************************************
(defun ( / *poly* *esel* *p*)
(while (not *poly*)
(setvar "errno" 0)
(setq *esel* (entsel ))
(setq *poly* (car *esel*))
(setq *p* (cadr *esel*))
(if (= 7 (getvar 'errno))
(alert "No objects selected")
)
(if (= 'ename (type *poly*))
(cond
( (null (wcmatch (cdr (assoc 0 (entget *poly*))) "LWPOLYLINE"))
(alert "Invalid selection, the object is not a LWPOLYLINE.")
(setq *poly* nil)
)
( (= 1 (logand 1 (cdr (assoc 70 (entget *poly*)))))
(alert "Invalid selection, the polyline is not open.")
(setq *poly* nil)
)
)
)
)
(list *poly* *p*)
)
;****************************************************************************
(defun check_elev ()
(if
(not
(equal
(cdr (assoc 38 (entget :e1)))
(cdr (assoc 38 (entget :e2)))
1e-6
)
)
(progn
(alert "Polylines have different elevation.")
(exit)
)
)
)
;****************************************************************************
(defun check_normal ()
(if
(or
(not (equal (cdr (assoc 210 (entget :e1))) '(0.0 0.0 1.0) ))
(not (equal (cdr (assoc 210 (entget :e2))) '(0.0 0.0 1.0) ))
)
(progn
(alert "Polyline is not normal to the WCS.")
(exit)
)
)
)
;****************************************************************************
(defun e_next (entL mode / next)
(if (= mode "SS") (setq next (ssadd)))
(if (/= entL (entlast))
(while (setq entL (entnext entL))
(if (entget entL)
(cond
( (= mode "LS") (setq next (cons entL next)) )
( (= mode "SS") (setq next (ssadd entL next)) )
)
)
)
)
next
)
;****************************************************************************
(defun check_offset ( / o_del)
(if rip (setq rip (1+ rip)) (setq rip 1))
(if (> (length (setq o_del (e_next EL "LS"))) 1)
(progn
(entdel e1)
(entdel e2)
(if (= rip 2) (entdel e1o))
(mapcar
'(lambda (x)
(if (not (vlax-erased-p x)) (entdel x))
)
o_del
)
(alert
(strcat
"Modeling failed."
"\nTry to split the polylines into more portions."
)
)
(exit)
)
)
)
;****************************************************************************
(defun MaxDist (ent1 ent2 / :step De1 :div p_step :D Dmax)
(setq :step (/ (setq De1 (vlax-curve-getDistAtParam ent1 (vlax-curve-getEndParam ent1))) 500))
(setq :div :step)
(setq Dmax 0.00)
(while ( :D Dmax) (setq Dmax :D))
(setq :div (+ :div :step))
)
Dmax
)
;****************************************************************************
(vl-load-com)
(prompt "\n ") (prompt "\n ")
(princ "\nCenterline between two polyline - by Gian Paolo Cattaneo")
(princ "\ncenterPline.LSP loaded ............... Type \"CPL\" to run ")
(princ)
(c:cpl)
页:
[1]