[LISP函数]：SPLINE转PLINE的小程序

caddog · 发表于 2006-8-30 23:12:53

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

在CADALYST上看到的一个SPLINE转PLINE的程序。各位看看

[FONT=courier new]
;;CADALYST 12/03 AutoLISP Solutions SPLINE-TO-PLINE.LSP
;;(c) 2003 Tony Hotchkiss
(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 "\nN鷐ero de segmentos <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 "\nSeleccione 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 hay entidades seleccionadas. Int閚talo de nuevo.")
) ;_ end of if
(if (and (= nil no-ent) (= nil spl-list))
(progn
(setq no-ent 1)
(prompt "\nNo hay splines seleccionadas.")
(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
(defun c:s2p ()
(spline-to-pline)
(princ)
) ;_ end of c:s2p
(prompt
"SPLINE-TO-PLINE by Tony Hotchkiss. Entrar S2P para iniciar"
) ;_ end of prompt
[/FONT]

[FONT=courier new] 
;;CADALYST 12/03 AutoLISP Solutions  SPLINE-TO-PLINE.LSP 
;;(c) 2003 Tony Hotchkiss 
 
(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 "\nN鷐ero de segmentos <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 "\nSeleccione 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 hay entidades seleccionadas. Int閚talo de nuevo.") 
    ) ;_ end of if 
    (if        (and (= nil no-ent) (= nil spl-list)) 
      (progn 
        (setq no-ent 1) 
        (prompt "\nNo hay splines seleccionadas.") 
        (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 
 
(defun c:s2p () 
  (spline-to-pline) 
  (princ) 
) ;_ end of c:s2p 
 
(prompt 
  "SPLINE-TO-PLINE by Tony Hotchkiss. Entrar S2P para iniciar" 
) ;_ end of prompt 
 
  [/FONT]

eachy · 发表于 2006-8-31 08:19:07

再贴另外一个 S2P

;;;CADALYST 01/06 Tip 2082: Spline2Pline2.lsp Spline to Polyline Conversion - Update
;;;(c) 2006 Cadalyst and Lloyd Beachy + narrator
;; Spline2Pline2.lsp (c) 2005 Lloyd Beachy + narrator
;; Routine to convert splines to plines
(Defun C:S2P2 (/ ss pt# cmdecho osmode clayer count ent lay lng pt-list
cnt)
(vl-load-com)
(setq ss (ssget '((0 . "spline")))
multi# (getint
"Please specify number of polyline points by a multiplicator of spline's control points, leave default for the same number <1>:"
)
cmdecho (getvar "cmdecho")
osmode (getvar "osmode")
clayer (getvar "clayer")
count 0 ;_spline counter
) ;_end setq
(if (null multi#)
(setq multi# 1)
)
(setvar "cmdecho" 0)
(command ".undo" "begin") ;_begin undo group
(setvar "osmode" 0)
(repeat (sslength ss) ;_repeat for each spline
(setq ent (vlax-ename->vla-object (ssname ss count)) ;_change spline to vla-object
lay (vlax-get-property ent "layer") ;_spline's layer
cp# (vlax-get-property ent "numberofcontrolpoints") ;_spline's control points number
lng (vlax-curve-getDistAtPoint ent (vlax-curve-getEndPoint ent)) ;_length of spline
pt-list (list (vlax-curve-getStartPoint ent)) ;_coords for start of spline
cnt 1.0 ;segment counter
pt# (* cp# multi#)
) ;_end setq
(repeat pt# ;_repeat for each segment
(setq pt-list
(cons (vlax-curve-getPointAtDist ent (* lng (/ cnt pt#)))
pt-list
)
) ;_add segment's point to pt-list
(setq cnt (1+ cnt)) ;_counter to next segment
) ;_end segment repeat
(setq cnt 0) ;_pline counter
(setvar "clayer" lay) ;_match spline's layer
(command ".pline" ;_start "pline" command
(repeat (length pt-list) ;_repeat for each point
(command (nth cnt pt-list)) ;_enter current point
(setq cnt (1+ cnt)) ;_counter to next point
"" ;_return value to close "pline" command
) ;_end point repeat
) ;_end command
(setq count (1+ count)) ;_counter to next spline
) ;_end spline repeat
(command ".erase" ss "")
(setvar "osmode" osmode)
(setvar "clayer" clayer)
(command ".undo" "end") ;_end of undo group
(setvar "cmdecho" cmdecho)
(princ) ;_exit quietly
) ;_end C:S2P

;;;CADALYST 01/06  Tip 2082: Spline2Pline2.lsp         Spline to Polyline Conversion - Update 
;;;(c) 2006 Cadalyst and Lloyd Beachy + narrator 
;; Spline2Pline2.lsp (c) 2005 Lloyd Beachy + narrator 
;; Routine to convert splines to plines 
(Defun C:S2P2 (/ ss pt#        cmdecho        osmode clayer count ent        lay lng        pt-list 
               cnt) 
  (vl-load-com) 
  (setq        ss        (ssget '((0 . "spline"))) 
        multi#        (getint 
                  "Please specify number of polyline points by a multiplicator of spline's control points, leave default for the same number <1>:" 
                ) 
        cmdecho        (getvar "cmdecho") 
        osmode        (getvar "osmode") 
        clayer        (getvar "clayer") 
        count        0 ;_spline counter 
  ) ;_end setq 
  (if (null multi#) 
    (setq multi# 1) 
  ) 
  (setvar "cmdecho" 0) 
  (command ".undo" "begin") ;_begin undo group 
  (setvar "osmode" 0) 
  (repeat (sslength ss) ;_repeat for each spline 
    (setq ent          (vlax-ename->vla-object (ssname ss count)) ;_change spline to vla-object 
          lay          (vlax-get-property ent "layer") ;_spline's layer 
          cp#          (vlax-get-property ent "numberofcontrolpoints") ;_spline's control points number 
          lng          (vlax-curve-getDistAtPoint ent (vlax-curve-getEndPoint ent)) ;_length of spline 
          pt-list (list (vlax-curve-getStartPoint ent)) ;_coords for start of spline 
          cnt          1.0                        ;segment counter 
          pt#          (* cp# multi#) 
    ) ;_end setq 
    (repeat pt# ;_repeat for each segment 
      (setq pt-list 
             (cons (vlax-curve-getPointAtDist ent (* lng (/ cnt pt#))) 
                   pt-list 
             ) 
      ) ;_add segment's point to pt-list 
      (setq cnt (1+ cnt)) ;_counter to next segment 
    ) ;_end segment repeat 
    (setq cnt 0) ;_pline counter 
    (setvar "clayer" lay) ;_match spline's layer 
    (command ".pline" ;_start "pline" command 
             (repeat (length pt-list) ;_repeat for each point 
               (command (nth cnt pt-list)) ;_enter current point 
               (setq cnt (1+ cnt)) ;_counter to next point 
               "" ;_return value to close "pline" command 
             ) ;_end point repeat 
    ) ;_end command 
    (setq count (1+ count)) ;_counter to next spline 
  ) ;_end spline repeat 
  (command ".erase" ss "") 
  (setvar "osmode" osmode) 
  (setvar "clayer" clayer) 
  (command ".undo" "end") ;_end of undo group 
  (setvar "cmdecho" cmdecho) 
  (princ) ;_exit quietly 
) ;_end C:S2P

snoopychen · 发表于 2006-8-31 09:06:47

请让我也来凑热闹：）我没有编过这个，只能好好学习了
具体帖子可见：
http://www.theswamp.org/index.php?topic=1804.0;all
首先
CAB根据楼主的要求发了两个现成的
1.这个不知道作者，精度还可以

(defun c:sptrace (/ ent spline cur pl end keep)
(setq cur nil)
(setq pl '((0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(8 . "0")
(100 . "AcDbPolyline")
(90 . 7)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
)
)
(setq end '(210 0.0 0.0 1.0));define polyline group codes
(while (not (progn (princ "\rSelect Spline: ") ;select spline to convert
(setq spline (ssget ":s" '((0 . "SPLINE"))))
)
)
)
(initget "Yes No")
(setq keep (getkword "Keep Original Spline [Yes/No]: "));keep original line or not
(setq spline (ssname spline 0)); get ename
(if (/= keep "No")
(progn
(entmake (entget spline));copy spline
(setq spline (entlast));get ename of new spline
)
)
(setq ent spline); copy ename to new variable
(command "splinedit" ent "refine" "elevate" 26 "x" "x");add extra control points
(setq ent (entget ent)); get data for spline
(setq pl (subst (assoc 8 ent) (assoc 8 pl) pl)); set polylines layer to same as spline
(if (= (rem (cdr (assoc 70 ent)) 2) 1);is spline closed
(setq pl (subst (cons 70 1) (assoc 70 pl) pl));set polyline closed
(setq pl (subst (cons 70 0) (assoc 70 pl) pl));set polyline open
)
(repeat (length ent);loop
(progn
(if (eq (car (car ent)) 10);get control point data
(setq cur (append cur (list (car ent))))
)
(setq ent (cdr ent));get next element in list
)
)
(setq pl (subst (cons 90 (length cur)) (assoc 90 pl) pl));set number of points in polyline
(repeat (length cur);loop
(progn;add polyline point data
(setq pl
(append
pl
(list (car cur) (cons 40 0.0) (cons 41 0.0) (cons 42 0.0))
)
)
(setq cur (cdr cur));get next element in list
)
)
(setq pl (append pl (list end)));add normal vector to polyline data
(entmake pl);make polyline
(entdel (cdr (assoc -1 (entget spline))));entdel spline, original or copy
(princ);exit quietly
)

(defun c:sptrace (/ ent spline cur pl end keep) 
 (setq cur nil) 
 (setq pl '((0 . "LWPOLYLINE") 
     (100 . "AcDbEntity") 
     (67 . 0) 
     (8 . "0") 
     (100 . "AcDbPolyline") 
     (90 . 7) 
     (70 . 0) 
     (43 . 0.0) 
     (38 . 0.0) 
     (39 . 0.0) 
    ) 
   ) 
 (setq end '(210 0.0 0.0 1.0));define polyline group codes 
 (while (not (progn (princ "\rSelect Spline: ") ;select spline to convert 
    (setq spline (ssget ":s" '((0 . "SPLINE")))) 
     ) 
) 
 ) 
 (initget "Yes No") 
 (setq keep (getkword "Keep Original Spline [Yes/No]: "));keep original line or not 
 (setq spline (ssname spline 0)); get ename 
 (if (/= keep "No") 
   (progn 
     (entmake (entget spline));copy spline 
     (setq spline (entlast));get ename of new spline 
     ) 
   ) 
 (setq ent spline); copy ename to new variable 
 (command "splinedit" ent "refine" "elevate" 26 "x" "x");add extra control points 
 (setq ent (entget ent)); get data for spline 
 (setq pl (subst (assoc 8 ent) (assoc 8 pl) pl)); set polylines layer to same as spline 
 (if (= (rem (cdr (assoc 70 ent)) 2) 1);is spline closed 
   (setq pl (subst (cons 70 1) (assoc 70 pl) pl));set polyline closed 
   (setq pl (subst (cons 70 0) (assoc 70 pl) pl));set polyline open 
 ) 
 (repeat (length ent);loop 
   (progn 
     (if (eq (car (car ent)) 10);get control point data 
(setq cur (append cur (list (car ent)))) 
     ) 
     (setq ent (cdr ent));get next element in list 
   ) 
 ) 
 (setq pl (subst (cons 90 (length cur)) (assoc 90 pl) pl));set number of points in polyline 
 (repeat (length cur);loop 
   (progn;add polyline point data 
     (setq pl 
    (append 
      pl 
      (list (car cur) (cons 40 0.0) (cons 41 0.0) (cons 42 0.0)) 
    ) 
     ) 
     (setq cur (cdr cur));get next element in list 
   ) 
 ) 
 (setq pl (append pl (list end)));add normal vector to polyline data 
 (entmake pl);make polyline 
 (entdel (cdr (assoc -1 (entget spline))));entdel spline, original or copy 
 (princ);exit quietly 
)

2.Mauricio Ferman的，精度一般，可能是方法问题

;Convert SPLINES to PLINES - Mauricio Ferman??2001
(defun c:spl2pl (/ splines plinetype osmode i spl ed codepair)
(if
(setq splines (ssget (list (cons 0 "spline"))))
(progn
(if
(zerop (setq plinetype (getvar "plinetype")))
(setvar "plinetype" 1)
) ;if
(setq osmode (getvar "osmode"))
(setvar "osmode" 0)
(setq i 0)
(while
(setq spl (ssname splines i))
(setq i (1+ i)
ed (entget spl)
) ;setq
(command ".pline")
(foreach
codepair
ed
(if
(= 10 (car codepair))
(command (cdr codepair))
) ;if
) ;foreach
(command "")
(command ".pedit" "l" "s" "")
) ;while
(if plinetype
(setvar "plinetype" plinetype)
)
(setvar "osmode" osmode)
) ;progn
) ;if
(princ)
) ;defun

;Convert SPLINES to PLINES - Mauricio Ferman??2001 
(defun c:spl2pl (/ splines plinetype osmode i spl ed codepair) 
  (if 
    (setq splines (ssget (list (cons 0 "spline")))) 
     (progn 
       (if 
         (zerop (setq plinetype (getvar "plinetype"))) 
          (setvar "plinetype" 1) 
       ) ;if 
       (setq osmode (getvar "osmode")) 
       (setvar "osmode" 0) 
       (setq i 0) 
       (while 
         (setq spl (ssname splines i)) 
          (setq i  (1+ i) 
                ed (entget spl) 
          ) ;setq 
          (command ".pline") 
          (foreach 
                    codepair 
                            ed 
            (if 
              (= 10 (car codepair)) 
               (command (cdr codepair)) 
            ) ;if 
          ) ;foreach 
          (command "") 
          (command ".pedit" "l" "s" "") 
       ) ;while 
       (if plinetype 
         (setvar "plinetype" plinetype) 
       ) 
       (setvar "osmode" osmode) 
     ) ;progn 
  ) ;if 
  (princ) 
) ;defun

3.Columbia（也是theswamp一位高手）写了一个子函数，我稍微加了一个运行函数test和一个绘制函数
这个直接有误差控制，可以模拟的很好

;;add this rountine to draw
(defun c:test (/ a ptlst)
(setq a (car (entsel))
tol 10
)
(setq ptlst (spline->pline a tol))
(make_pline ptlst 2)
)
(vl-load-com)
;Spline->Pline
(defun Spline->Pline (oSpline tol / 1stPoint dist fullLength lastPoint plinePoints point)
(setq 1stPoint (vlax-curve-getPointAtParam oSpline (vlax-curve-getStartParam oSpline))
lastPoint (vlax-curve-getPointAtParam oSpline (vlax-curve-getEndParam oSpline))
fullLength (vlax-curve-getdistatparam oSpline (vlax-curve-getendparam oSpline))
dist 0
plinePoints (list 1stPoint)
)
(while (< (setq dist (+ dist tol)) fullLength)
(if (setq point (vlax-curve-getPointAtDist oSpline dist))
(setq plinePoints (append plinePoints (list point)))
)
)
(setq plinePoints (append plinePoints (list lastpoint)))
;;; Use the variable plinePoints (which is a list of vertex points)
;;; and whatever method you like to use for adding a polyline
;;; to the drawing.
)
;;;makepline
(defun make_pline(lst color)
(entmakex
(append
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst))
'(70 . 0)
(cons 62 color)
) ;_ list
(mapcar '(lambda (x) (cons 10 x)) lst)
) ;_ append
)
)

;;add this rountine to draw 
(defun c:test (/ a ptlst) 
  (setq a (car (entsel)) 
        tol 10 
  ) 
  (setq ptlst (spline->pline a tol)) 
  (make_pline ptlst 2) 
) 
 
 
(vl-load-com) 
;Spline->Pline 
(defun Spline->Pline (oSpline tol / 1stPoint dist fullLength lastPoint plinePoints point) 
  (setq 1stPoint (vlax-curve-getPointAtParam oSpline (vlax-curve-getStartParam oSpline)) 
        lastPoint (vlax-curve-getPointAtParam oSpline (vlax-curve-getEndParam oSpline)) 
        fullLength (vlax-curve-getdistatparam oSpline (vlax-curve-getendparam oSpline)) 
        dist 0 
        plinePoints (list 1stPoint) 
  ) 
  (while (< (setq dist (+ dist tol)) fullLength)    
    (if (setq point (vlax-curve-getPointAtDist oSpline dist)) 
      (setq plinePoints (append plinePoints (list point))) 
    ) 
  ) 
  (setq plinePoints (append plinePoints (list lastpoint))) 
;;; Use the variable plinePoints (which is a list of vertex points) 
;;; and whatever method you like to use for adding a polyline 
;;; to the drawing. 
) 
 
;;;makepline 
(defun make_pline(lst color) 
(entmakex 
  (append 
    (list 
      '(0 . "LWPOLYLINE") 
      '(100 . "AcDbEntity") 
      '(100 . "AcDbPolyline") 
      (cons 90 (length lst)) 
      '(70 . 0) 
      (cons 62 color) 
    ) ;_  list 
    (mapcar '(lambda (x) (cons 10 x)) lst) 
  ) ;_  append 
) 
)

4.CAB在COLUMBIA的基础上进行一些批量处理,会删除原spline的
第一个用COMMAND

(defun c:spl2pl(/ usrlay usrosm usrplw ent pdist idx ss )
(setq usrosm (getvar "osmode"))
(setq usrplw (getvar "plinewid"))
(setvar "plinewid" 0 )
(setvar "osmode" 0 )
(setq pdist 36) ; distance between points on new pline
(if (setq ss (ssget '((0 . "SPLINE")))); get all splines
(progn
(setq idx (sslength ss))
(while (>= (setq idx (1- idx)) 0)
(setq ent (ssname ss idx))
(if (setq plist (Spline->Pline ent pdist))
(progn
(command "._pline" )
(mapcar '(lambda (x) (command x)) plist)
(command "")
(command "._change" "_Last" "" "_P" "_LA" (cdr(assoc 8(entget ent)))"")
(entdel ent)
) ; progn
); endif
) ; while
) ; progn
(prompt "\nNo splines in drawing.")
) ;endif
(setvar "osmode" usrosm)
(setvar "plinewid" usrplw)
(princ)
);defun

(defun c:spl2pl(/ usrlay usrosm usrplw ent pdist idx ss ) 
  (setq usrosm (getvar "osmode")) 
  (setq usrplw (getvar "plinewid")) 
  (setvar "plinewid" 0 ) 
  (setvar "osmode" 0 ) 
  (setq pdist 36) ; distance between points on new pline 
  (if (setq ss (ssget '((0 . "SPLINE")))); get all splines 
    (progn 
      (setq idx (sslength ss)) 
      (while (>= (setq idx (1- idx)) 0) 
        (setq ent (ssname ss idx)) 
        (if (setq plist (Spline->Pline ent pdist)) 
          (progn 
            (command "._pline" ) 
            (mapcar '(lambda (x) (command x)) plist) 
            (command "") 
            (command "._change" "_Last" "" "_P" "_LA" (cdr(assoc 8(entget ent)))"") 
            (entdel ent) 
          ) ; progn 
        ); endif 
      ) ; while 
    ) ; progn 
    (prompt "\nNo splines in drawing.") 
  ) ;endif 
  (setvar "osmode" usrosm) 
  (setvar "plinewid" usrplw) 
  (princ) 
);defun

第二个用ENTMAKE

(defun c:spl2pl(/ usrlay usrosm usrplw ent pdist idx ss pl plist pentlst)
(setq pdist 36) ; distance between points on new pline
(setq pentlst '((0 . "LWPOLYLINE")
(100 . "AcDbEntity")
(67 . 0)
(8 . "0")
(100 . "AcDbPolyline")
(90 . 7)
(70 . 0)
(43 . 0.0)
(38 . 0.0)
(39 . 0.0)
)
)
(setq end '(210 0.0 0.0 1.0));define polyline group codes
(if (setq ss (ssget '((0 . "SPLINE")))); get all splines
(progn
(setq idx (sslength ss))
(while (>= (setq idx (1- idx)) 0)
(setq ent (ssname ss idx)
pl pentlst)
(if (setq plist (Spline->Pline ent pdist))
(progn
(foreach x plist
(setq pl (append pl
(list (cons 10 (list (car x)(cadr x)))
(cons 40 0.0)
(cons 41 0.0)
(cons 42 0.0))))
)
;;set number of points in polyline
(setq pl (append
(subst (cons 90 (length plist)) (assoc 90 pl) pl)
pl
(list end))
)
;; update layer
(setq pl (subst (assoc 8 (entget ent)) (assoc 8 pl) pl))
(entmake pl);make polyline
(entdel ent)
) ; progn
); endif
) ; while
) ; progn
(prompt "\nNo splines in drawing.")
) ;endif
(princ)
)

(defun c:spl2pl(/ usrlay usrosm usrplw ent pdist idx ss pl plist pentlst) 
  (setq pdist 36) ; distance between points on new pline 
  (setq pentlst '((0 . "LWPOLYLINE") 
     (100 . "AcDbEntity") 
     (67 . 0) 
     (8 . "0") 
     (100 . "AcDbPolyline") 
     (90 . 7) 
     (70 . 0) 
     (43 . 0.0) 
     (38 . 0.0) 
     (39 . 0.0) 
    ) 
   ) 
  (setq end '(210 0.0 0.0 1.0));define polyline group codes 
  (if (setq ss (ssget  '((0 . "SPLINE")))); get all splines 
    (progn 
      (setq idx (sslength ss)) 
      (while (>= (setq idx (1- idx)) 0) 
        (setq ent (ssname ss idx) 
              pl pentlst) 
        (if (setq plist (Spline->Pline ent pdist)) 
          (progn 
            (foreach x plist 
              (setq pl (append pl 
                        (list (cons 10 (list (car x)(cadr x))) 
                              (cons 40 0.0) 
                              (cons 41 0.0) 
                              (cons 42 0.0)))) 
            ) 
            ;;set number of points in polyline 
            (setq pl (append 
                       (subst (cons 90 (length plist)) (assoc 90 pl) pl) 
                       pl 
                       (list end)) 
            ) 
            ;;  update layer 
            (setq pl (subst (assoc 8 (entget ent)) (assoc 8 pl) pl)) 
            (entmake pl);make polyline 
            (entdel ent) 
          ) ; progn 
        ); endif 
      ) ; while 
    ) ; progn 
    (prompt "\nNo splines in drawing.") 
  ) ;endif 
  (princ) 
)

从这个学习中看到，spline2pline的处理方法
caddog和eachy兄贴的都用了vlax-curve函数，不知名作者采用了splinedit的refine方法，Mauricio Ferman采用了直接提取控制
点的方法，精度应该就差了，而columbia和cab用的仍然是vlax-curve的方法，应该说，这种精度可以人为选择，可以达到很高水平。据说还有一种转成DXF 12格式再导入的方法，应该也是一种没有程序时候的变通方法吧。

eachy · 发表于 2006-8-31 13:18:21

综合 2 楼和 Mauricio Ferman 的方法就可以写出纯 Lisp 简单而实用的 Spline -〉Pline 程序。

有兴趣的可以对比下各个程序的效果

http://www.xdcad.net/forum/showthread.php?threadid=576444

雨箭风刀 · 发表于 2006-8-31 14:12:35

建议把各个程序对比测试,把图贴出来

cy956 · 发表于 2006-8-31 14:37:18

这个问题还应该引伸为插点合并和自动加入。

eachy · 发表于 2006-8-31 15:41:31

上面几个程序归纳起来有几种方法：

1 用 Param 对整条线均分，这种方法很容易想到，早期这样写的居多

2 在第一种方法上改进，利用 Spline 控制点，在控制点间等分，这种方法可以改进第一种方法中的取点不合理的地方，尤其在转折处的改善

3 还有一种方法就是利用 Pline 的样条化，利用 Spline 的控制点绘制 Pline ，然后执行样条化。但是这种方法对曲率变换较大的 SPline 将产生很大的偏离。

还看过 ARX 对这种模拟的处理，好像是什么弓高比，ARX 中提供了相应的一些函数，考虑到执行效率是无法使用在 Lisp 中的.

就一砖头 · 发表于 2006-8-31 16:40:59

都是我学习的好榜样多谢斑竹

雨箭风刀 · 发表于 2006-8-31 19:42:26

还有没有别的方法？

eachy · 发表于 2006-9-1 06:05:29

还有一种就是在 4 楼说的：）

WHGF · 发表于 2006-9-1 07:38:45

这是我以前做的程序，还有抽稀线功能模块！采用的是另外一种方法精度很高
http://www.xdcad.net/forum/showt ... 2530879#post2530879

eachy · 发表于 2006-9-1 08:26:47

4 楼的方法应该和这种转化类似，精度由 CAD 控制，只是不用 DXFOUT ，利用 Pline-〉样条化作为过渡，Pline 样条化的线就是一段段的 Line ，由这一段段 Line 的 Point 影射到 Spline 上就是那些拟和点。

前面的几个程序都是分开来做，没有完成最后一步将点影射到Spline后再次生成 Pline

WHGF · 发表于 2006-9-1 12:05:48

如果有时间好好研究一下楼上各位的方法。学习中！

caddog · 发表于 2006-9-1 12:19:07

没想到我抛了一块砖，引来众位这么多玉：)一定好好地学习学习。

雨箭风刀 · 发表于 2006-9-1 13:23:55

转贴lucas以前的一篇

;;利用OFFSET特性(对SPLINE & ELLIPSE OFFSET后会增加控制点)
;;SPLINE & ELLIPSE TO PLINE
;;BY 龙龙仔(LUCAS)
(defun C:S2P (/ HOLDOSMODE HOLDECHO SSS SSL N N1 ENT PT_LIST NUMPT ED PT PT1)
;;T. Tanzillo
(defun VLISP-REMOVE-IF-NOT (KEY LST)
(mapcar 'cdr
(vl-remove-if-not
'(lambda (E) (eq (car E) KEY))
LST
)
)
)
(defun MIDPOINT (PT1 PT2)
(mapcar
'(lambda (X Y)
(* 0.5 (+ X Y))
)
PT1
PT2
)
)
(setq HOLDECHO (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "_.undo" "group")
(setq HOLDOSMODE (getvar "osmode"))
(setvar "osmode" 0)
(prompt "\n选取SPLINE,ELLIPSE:")
(setq SSS (ssget '((0 . "ELLIPSE,SPLINE"))))
(setq SSL (sslength SSS)
N 0
)
(repeat SSL
(prompt (strcat "\r余 " (itoa (- SSL N)) " 个物件 "))
(setq ENT (vlax-ename->vla-object (ssname SSS N)))
(vl-catch-all-apply
'vla-offset
(list ENT 0.001)
)
(setq ENT (entlast))
(vl-catch-all-apply
'vla-offset
(list (vlax-ename->vla-object ENT) -0.001)
)
(entdel ENT)
(setq ENT (entlast))
(setq PT_LIST (VLISP-REMOVE-IF-NOT 10 (setq ED (entget ENT))))
(setq ENT (vlax-ename->vla-object ENT))
(setq N1 0)
(vl-cmdf "_.pline" (nth N1 PT_LIST) "A")
(if (or (and (= (cdr (assoc 0 ED)) "ELLIPSE")
(= (cdr (assoc 42 ED)) (* pi 2))
)
(and (= (cdr (assoc 0 ED)) "SPLINE")
(= (logand (cdr (assoc 70 ED)) 1) 1)
)
)
(setq NUMPT (- (length PT_LIST) 2))
(setq NUMPT (- (length PT_LIST) 1))
)
(repeat NUMPT
(setq PT (vlax-curve-getclosestpointto
ENT
(MIDPOINT (nth N1 PT_LIST)
(setq PT1 (nth (1+ N1) PT_LIST))
)
)
)
(vl-cmdf "S"
(vlax-curve-getclosestpointto ENT PT)
(vlax-curve-getclosestpointto ENT PT1)
)
(setq N1 (1+ N1))
)
(if (or (and (= (cdr (assoc 0 ED)) "ELLIPSE")
(= (cdr (assoc 42 ED)) (* pi 2))
)
(and (= (cdr (assoc 0 ED)) "SPLINE")
(= (logand (cdr (assoc 70 ED)) 1) 1)
)
)
(vl-cmdf "CL")
(vl-cmdf "")
)
(vla-delete ENT)
(setq N (1+ N))
)
(setvar "osmode" HOLDOSMODE)
(command "_.undo" "end")
(setvar "cmdecho" HOLDECHO)
(princ)
)

;;利用OFFSET特性(对SPLINE & ELLIPSE  OFFSET后会增加控制点) 
;;SPLINE & ELLIPSE TO PLINE 
;;BY  龙龙仔(LUCAS) 
(defun C:S2P (/ HOLDOSMODE HOLDECHO SSS SSL N N1 ENT PT_LIST NUMPT ED PT PT1) 
  ;;T. Tanzillo 
  (defun VLISP-REMOVE-IF-NOT (KEY LST) 
    (mapcar 'cdr 
     (vl-remove-if-not 
       '(lambda (E) (eq (car E) KEY)) 
       LST 
     ) 
    ) 
  ) 
 
  (defun MIDPOINT (PT1 PT2) 
    (mapcar 
      '(lambda (X Y) 
  (* 0.5 (+ X Y)) 
       ) 
      PT1 
      PT2 
    ) 
  ) 
 
  (setq HOLDECHO (getvar "cmdecho")) 
  (setvar "cmdecho" 0) 
  (command "_.undo" "group") 
  (setq HOLDOSMODE (getvar "osmode")) 
  (setvar "osmode" 0) 
  (prompt "\n选取SPLINE,ELLIPSE:") 
  (setq SSS (ssget '((0 . "ELLIPSE,SPLINE")))) 
  (setq SSL (sslength SSS) 
 N   0 
  ) 
  (repeat SSL 
    (prompt (strcat "\r余 " (itoa (- SSL N)) " 个物件     ")) 
    (setq ENT (vlax-ename->vla-object (ssname SSS N))) 
    (vl-catch-all-apply 
      'vla-offset 
      (list ENT 0.001) 
    ) 
    (setq ENT (entlast)) 
    (vl-catch-all-apply 
      'vla-offset 
      (list (vlax-ename->vla-object ENT) -0.001) 
    ) 
    (entdel ENT) 
    (setq ENT (entlast)) 
    (setq PT_LIST (VLISP-REMOVE-IF-NOT 10 (setq ED (entget ENT)))) 
    (setq ENT (vlax-ename->vla-object ENT)) 
    (setq N1 0) 
    (vl-cmdf "_.pline" (nth N1 PT_LIST) "A") 
    (if (or (and (= (cdr (assoc 0 ED)) "ELLIPSE") 
   (= (cdr (assoc 42 ED)) (* pi 2)) 
     ) 
     (and (= (cdr (assoc 0 ED)) "SPLINE") 
   (= (logand (cdr (assoc 70 ED)) 1) 1) 
     ) 
 ) 
      (setq NUMPT (- (length PT_LIST) 2)) 
      (setq NUMPT (- (length PT_LIST) 1)) 
    ) 
    (repeat NUMPT 
      (setq PT (vlax-curve-getclosestpointto 
   ENT 
   (MIDPOINT (nth N1 PT_LIST) 
      (setq PT1 (nth (1+ N1) PT_LIST)) 
   ) 
        ) 
      ) 
      (vl-cmdf "S" 
        (vlax-curve-getclosestpointto ENT PT) 
        (vlax-curve-getclosestpointto ENT PT1) 
      ) 
      (setq N1 (1+ N1)) 
    ) 
    (if (or (and (= (cdr (assoc 0 ED)) "ELLIPSE") 
   (= (cdr (assoc 42 ED)) (* pi 2)) 
     ) 
     (and (= (cdr (assoc 0 ED)) "SPLINE") 
   (= (logand (cdr (assoc 70 ED)) 1) 1) 
     ) 
 ) 
      (vl-cmdf "CL") 
      (vl-cmdf "") 
    ) 
    (vla-delete ENT) 
    (setq N (1+ N)) 
  ) 
  (setvar "osmode" HOLDOSMODE) 
  (command "_.undo" "end") 
  (setvar "cmdecho" HOLDECHO) 
  (princ) 
)

第一次测试：
http://fs3.139.com/1/1021/dreamsky_lxx/photo/200691133350179.jpg
贴不上图，只好给个连接
评分标准：
优化 1~3
精度 1~3
越大越好
打*号表示可以通过输入数字调整精度。
考虑到评测时有主观观测的误差，结果仅作参考

下面是用到xdapi，因无cad2004，没有进行测试

;;; 命令curve2pl
;;; 功能：循环多选circle,ellipse,arc,spline用
;;; polyline模拟，生成的多义线类型由当前
;;; 系统的plinetype变量控制。
;;; 程序在一次循环中提示一次是否删除旧的曲线
;;; 请加载xdrx_api
(defun c:curve2pl (/ ss ptl e sel #del_curve_flag #is_closed)
(defun #is_closed (name / tf1)
(setq tf1 t)
(cond
((= "ARC" name)
(setq tf1 nil)
)
((= "ELLIPSE" name)
(if (> (abs (- (xdrx_getentdxf 42) (xdrx_getentdxf 41))) 1e-5)
(setq tf1 nil)
)
)
((= "SPLINE" name)
(if (= (logand (xdrx_getentdxf 70) 1) 0)
(setq tf1 nil)
)
)
)
tf1
)
(while (progn
(prompt "\n请选取要用多义线模拟的circle,arc,ellipse,spline<退出>:")
(setq ss (ssget '((0 . "circle,arc,ellipse,spline"))))
)
(xdrx_setsstodb ss 0)
(while (setq e (xdrx_getentdata 0))
(setq ptl (xdrx_getsamplept e))
(if (not #del_curve_flag)
(progn
(initget 0 "Yes No")
(if (not (setq sel (getkword (strcat "\n是否删除旧的曲线<Yes>:"))))
(setq #del_curve_flag "Yes")
(setq #del_curve_flag sel)
)
)
)
(if (= "Yes" #del_curve_flag)
(entdel e)
)
(apply
'command
(cons "pline" ptl)
)
(if (#is_closed (xdrx_getentdxf 0))
(command "c")
(command "")
)
)
)
(princ)
)

;;; 命令curve2pl 
;;; 功能：循环多选circle,ellipse,arc,spline用 
;;;      polyline模拟，生成的多义线类型由当前 
;;;      系统的plinetype变量控制。 
;;; 程序在一次循环中提示一次是否删除旧的曲线 
;;; 请加载xdrx_api 
 
(defun c:curve2pl (/ ss ptl e sel #del_curve_flag #is_closed) 
  (defun #is_closed (name / tf1) 
    (setq tf1 t) 
    (cond 
      ((= "ARC" name) 
    (setq tf1 nil) 
      ) 
      ((= "ELLIPSE" name) 
    (if (> (abs (- (xdrx_getentdxf 42) (xdrx_getentdxf 41))) 1e-5) 
      (setq tf1 nil) 
    ) 
      ) 
      ((= "SPLINE" name) 
    (if (= (logand (xdrx_getentdxf 70) 1) 0) 
      (setq tf1 nil) 
    ) 
      ) 
    ) 
    tf1 
  ) 
 
  (while (progn 
      (prompt "\n请选取要用多义线模拟的circle,arc,ellipse,spline<退出>:") 
      (setq ss (ssget '((0 . "circle,arc,ellipse,spline")))) 
     ) 
    (xdrx_setsstodb ss 0) 
    (while (setq e (xdrx_getentdata 0)) 
      (setq ptl (xdrx_getsamplept e)) 
      (if (not #del_curve_flag) 
    (progn 
      (initget 0 "Yes No") 
      (if (not (setq sel (getkword (strcat "\n是否删除旧的曲线<Yes>:")))) 
        (setq #del_curve_flag "Yes") 
        (setq #del_curve_flag sel) 
      ) 
    ) 
      ) 
      (if (= "Yes" #del_curve_flag) 
    (entdel e) 
      ) 
      (apply 
    'command 
    (cons "pline" ptl) 
      ) 
      (if (#is_closed (xdrx_getentdxf 0)) 
    (command "c") 
    (command "") 
      ) 
    ) 
  ) 
  (princ) 
)

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

[LISP函数]：SPLINE转PLINE的小程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

浏览过的版块