lisp 多段线转面域_样条曲线转多段线（转发） - AutoLISP/Visual LISP 编程技术 - CAD论坛 - 明经CAD社区 - Powered by Discuz!...

;;CADALYST 12/03 AutoLISP Solutions SPLINE-TO-PLINE.LSP

;;(c) 2003 Tony Hotchkiss

(defun c:test ()

;(defun spline-to-pline (/ i)

(vl-load-com)

(setq *thisdrawing* (vla-get-activedocument

(vlax-get-acad-object)

) ;_ end of vla-get-activedocument

*modelspace* (vla-get-ModelSpace *thisdrawing*)

) ;_ end of setq

(setq spline-list (get-spline))

(setq i (- 1))

(if spline-list

(progn

(setq msg "\nNumber of segments <100>: ")

(initget 6)

(setq num (getint msg))

(if (or (= num 100) (= num nil))

(setq num 100)

) ;_ end of if

(repeat (length spline-list)

(setq splobj (nth (setq i (1+ i)) spline-list))

(convert-spline splobj num)

) ;_ end of repeat

) ;_ end of progn

) ;_ end of if

) ;_ end of spline-to-pline

(defun get-spline (/ spl-list obj spline no-ent i)

(setq spl-list nil

obj nil

spline "AcDbSpline"

selsets (vla-get-selectionsets *thisdrawing*)

ss1 (vlax-make-variant "ss1")

) ;_ end of setq

(if (= (vla-get-count selsets) 0)

(setq ssobj (vla-add selsets ss1))

) ;_ end of if

(vla-clear ssobj)

(setq no-ent 1)

(while no-ent

(prompt "\nSelect splines: ")

(vla-Selectonscreen ssobj)

(if (> (vla-get-count ssobj) 0)

(progn

(setq no-ent nil)

(setq i (- 1))

(repeat (vla-get-count ssobj)

(setq

obj (vla-item ssobj

(vlax-make-variant (setq i (1+ i)))

) ;_ end of vla-item

) ;_ end of setq

(cond

((= (vlax-get-property obj "ObjectName") spline)

(setq spl-list

(append spl-list (list obj))

) ;_ end of setq

)

) ;_ end-of cond

) ;_ end of repeat

) ;_ end of progn

(prompt "\nNo entities selected, try again.")

) ;_ end of if

(if (and (= nil no-ent) (= nil spl-list))

(progn

(setq no-ent 1)

(prompt "\nNo splines selected.")

(quit)

) ;_ end of progn

) ;_ end of if

) ;_ end of while

(vla-delete (vla-item selsets 0))

spl-list

) ;_ end of get-spline

(defun convert-spline (splobj n / i)

(setq point-list nil

2Dpoint-list nil

z-list nil

spl-lyr (vlax-get-property splobj 'Layer)

startSpline (vlax-curve-getStartParam splobj)

endSpline (vlax-curve-getEndParam splobj)

i (- 1)

) ;_ end of setq

(repeat (+ n 1)

(setq i (1+ i))

(setq p (vlax-curve-getPointAtParam

splobj

(* i

(/ (- endspline startspline) n)

) ;_ end of *

) ;_ end of vlax-curve-getPointAtParam

) ;_ end of setq

(setq 2Dp (list (car p) (cadr p))

2Dpoint-list (append 2Dpoint-list 2Dp)

point-list (append point-list p)

z (caddr p)

z-list (append z-list (list z))

) ;_ end of setq

) ;_ end of repeat

(setq summ (apply '+ z-list))

(setq arraySpace

(vlax-make-safearray

vlax-vbdouble ; element type

(cons 0

(- (length point-list) 1)

) ; array dimension

) ;_ end of vlax-make-safearray

) ;_ end of setq

(setq vert-array (vlax-safearray-fill arraySpace point-list))

(vlax-make-variant vert-array)

(if (and (= :vlax-true (vlax-get-property splobj 'IsPLanar))

(= summ 0.0)

) ;_ end of and

(setq plobj (add-polyline

2Dpoint-list

vla-AddLightweightPolyline

) ;_ end of add-polyline

) ;_ end of setq

(setq plobj (add-polyline

point-list

vla-Add3DPoly

) ;_ end of add-polyline

) ;_ end of setq

) ;_ end of if

(vlax-put-property plobj 'Layer spl-lyr)

(vla-delete splobj)

(vlax-release-object splobj)

) ;_ end of convert-spline

(defun add-polyline (pt-list poly-func)

(setq arraySpace

(vlax-make-safearray

vlax-vbdouble

(cons 0

(- (length pt-list) 1)

) ; array dimension

) ;_ end of vlax-make-safearray

) ;_ end of setq

(setq vertex-array

(vlax-safearray-fill arraySpace pt-list)

) ;_ end of setq

(vlax-make-variant vertex-array)

(setq plobj (poly-func

*modelspace*

vertex-array

) ;_ end of poly-func

) ;_ end of setq

) ;_ end of add-polyline