晓东CAD家园-论坛-A/VLISP-拟合的POLYLINE转SPLINE-函数 points ：**** 本内容被作者隐藏 ****

newer 发表于 2017-7-14 13:02:02

拟合的POLYLINE转SPLINE

(defun c:2ndss2spls ( / *error* arc2spl line2spl loop sss i ent ssss )

(vl-load-com)

(defun *error* ( msg )
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(if msg (prompt msg))
(princ)
)

(defun arc2spl ( e / make_spline points q1 q2 a pc f pe ps w )

      (setq q1 (vlax-curve-GetStartParam e)
            q2 (vlax-curve-GetEndParam e)
            a(/ (- (vlax-curve-GetEndParam e) (vlax-curve-GetStartParam e)) 3.0) ; a - parameter interval... and angle
            pc (mapcar                            ; pc - points on contur
                  (function
                     (lambda (p)
                     (vlax-curve-GetPointAtParam e p)
                     )
                     )
                  (list q1 (+ q1 a) (- q2 a) q2)
               )
            f(mapcar                            ; f - first deriv on pc
                  (function
                     (lambda (p)
                     (vlax-curve-GetFirstDeriv e p)
                     )
                     )
                  (list q1 (+ q1 a) (- q2 a) q2)
               )
            pe (mapcar                            ; pe - extra control points for spline construction
                  (function
                     (lambda (p1 p2 d1 d2)
                     (inters p1 (mapcar '+ p1 d1)
                              p2 (mapcar '+ p2 d2)
                              nil
                              )
                     )
                  )
                  pc (cdr pc) f (cdr f)
               )
            ps(list (car pc) (car pe) (cadr pc) (cadr pe) (caddr pc) (caddr pe) (cadddr pc)) ; ps - control points for spline
            w (list 1.0 (cos (/ a 2)) 1.0 (cos (/ a 2)) 1.0 (cos (/ a 2)) 1.0); weights for spline
      )

(defun make_spline ( pts )
   (entmakex
   (append
      '((0 . "SPLINE") (100 . "AcDbEntity") (100 . "AcDbSpline")
         (70 . 4) (71 . 2) (72 . 10) (73 . 7) (74 . 0)
         (42 . 1.0e-010) (43 . 1.0e-010)
         (40 . 0.0) (40 . 0.0) (40 . 0.0) (40 . 1.0) (40 . 1.0)
         (40 . 2.0) (40 . 2.0) (40 . 3.0) (40 . 3.0) (40 . 3.0))
      pts
   )
   )
)

(entdel e)
(make_spline (points ps w))

)

(defun line2spl ( e / sp ep d )

(setq sp (cdr (assoc 10 (entget e)))
      ep (cdr (assoc 11 (entget e)))
      d (distance sp ep)
)

(entdel e)

(entmakex
   (list
   '(0 . "SPLINE") '(100 . "AcDbEntity") '(100 . "AcDbSpline") '(210 0.0 0.0 1.0) '(71 . 1) '(73 . 2)
   '(42 . 1.0e-010) '(43 . 1.0e-010) '(40 . 0.0) '(40 . 0.0) (cons 40 d) (cons 40 d) (cons 10 sp) (cons 10 ep)
   )
)

)

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(setq loop T)
(setq sss (ssget "_I"))
(if
(and
   sss
   (vl-some '(lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "LINE,ARC,*POLYLINE")) (vl-remove-if 'listp (mapcar 'cadr (ssnamex sss))))
)
(setq loop nil)
)
(while loop
(setq sss (ssget "_:L" (list '(-4 . "<or") '(0 . "LINE,ARC,LWPOLYLINE") '(-4 . "<and") '(0 . "POLYLINE") '(-4 . "<or") '(70 . 0) '(70 . 1) '(70 . 8) '(70 . 9) '(70 . 128) '(70 . 129) '(-4 . "or>") '(-4 . "and>") '(-4 . "or>"))))
(if sss (setq loop nil))
)
(setq ssss (ssadd))
(repeat (setq i (sslength sss))
(setq ent (ssname sss (setq i (1- i))))
(cond
   ( (eq (cdr (assoc 0 (entget ent))) "LINE")
   (line2spl ent)
   (ssadd (entlast) ssss)
   )
   ( (eq (cdr (assoc 0 (entget ent))) "ARC")
   (arc2spl ent)
   (ssadd (entlast) ssss)
   )
   ( (eq (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
   (sssetfirst nil (ssadd ent))
   (c:lw2spl)
   (ssadd (entlast) ssss)
   (sssetfirst nil nil)
   )
   ( (and
      (eq (cdr (assoc 0 (entget ent))) "POLYLINE")
      (or
         (eq (cdr (assoc 70 (entget ent))) 0)
         (eq (cdr (assoc 70 (entget ent))) 1)
         (eq (cdr (assoc 70 (entget ent))) 128)
         (eq (cdr (assoc 70 (entget ent))) 129)
      )
   )
   (command "_.CONVERTPOLY" "_L" ent)
   (while (> (getvar 'cmdactive) 0) (command ""))
   (sssetfirst nil (ssadd ent))
   (c:lw2spl)
   (ssadd (entlast) ssss)
   (sssetfirst nil nil)
   )
   ( (and
      (eq (cdr (assoc 0 (entget ent))) "POLYLINE")
      (or
         (eq (cdr (assoc 70 (entget ent))) 8)
         (eq (cdr (assoc 70 (entget ent))) 9)
      )
   )
   (sssetfirst nil (ssadd ent))
   (c:3p2spl)
   (ssadd (entlast) ssss)
   (sssetfirst nil nil)
   )
)
)
(sssetfirst nil ssss)
(*error* nil)
)

(defun c:oldheavyfit2spl ( / *error* *adoc* ss pl sp e sss )

(vl-load-com)

(defun *error* ( m )
(vla-endundomark *adoc*)
(if m
   (prompt m)
)
(princ)
)

(vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
(prompt "\nPick old heavy 2d polyline that is curve fited...")
(setq ss (ssget "_+.:E:S:L" (list '(0 . "POLYLINE") '(-4 . "<or") '(70 . 2) '(70 . 3) '(70 . 130) '(70 . 131) '(-4 . "or>"))))
(if ss
(progn
   (setq pl (ssname ss 0))
   (setq sp (vlax-curve-getstartpoint pl))
   (command "_.EXPLODE" pl)
   (while (< 0 (getvar 'cmdactive))
   (command "")
   )
   (sssetfirst nil (ssget "_P"))
   (c:2ndss2spls)
   (setq sss (cadr (ssgetfirst)))
   (setq e (car (nentselp (trans sp 0 1))))
   (command "_.JOIN" e sss "")
)
)
(*error* nil)
)

函数 points ：

**** Hidden Message *****

/db_自贡黄明儒_ 发表于 2017-7-14 13:14:14

听说爆破一下就可以了，不知道是不是真的。很难遇到POLYLINE线，也无法验证

newer 发表于 2017-7-14 13:17:02

/db_自贡黄明儒_ 发表于 2017-7-14 13:14

自己画个2D POLYLINE不就验证了,你说的爆破一下是做什么？变SPLINE ？

ynhh 发表于 2017-7-14 13:25:55

感谢版主的分享
谢谢

q3_2006 发表于 2017-7-14 17:12:47

我以为是反过来..样条转多段线

waterchen 发表于 2017-7-19 15:01:14

好程序，謝謝分享！

zixuan203344 发表于 2017-7-19 19:14:02

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

yoyoho 发表于 2017-7-19 19:46:26

实用程序谢谢分享！！！

laiz3000 发表于 2017-7-20 00:56:40

{:1_1:}回复看看

crtrccrt 发表于 2017-7-20 07:52:03

做好事业务的一样

434939575 发表于 2017-10-26 17:49:49

进来学习哈，谢谢！

819534890 发表于 2017-10-27 09:26:49

回复学习，谢谢分享

HLCAD 发表于 2017-10-27 11:45:25

感谢自主分享程序

960322 发表于 2017-11-7 23:46:53

不会吧，还可以这样

pezyl 发表于 2018-1-18 09:51:51

多数是spline转polyline，这个牛逼谢谢分享

页: [1] 2 3

晓东CAD家园-论坛's Archiver

拟合的POLYLINE转SPLINE