【求助】下面网址中的程序有问题，可否帮忙修改一下

yangchao2005090 · 发表于 2021-8-20 21:25

https://lispbox.wordpress.com//?s=centerpline.lsp&search=Go
centerpline.lsp

yangchao2005090 · 发表于 2021-8-20 21:27

;;;************************ 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)

;;;************************ 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)

账号		自动登录	找回密码
密码			注册