Jump to content
jntm226

select multiple polylines and convert straight to arc segments

Recommended Posts

jntm226

this lisp convert polyline segments to arcs . work one line for time . i need select 1000 polylines for times. I'm new in autolisp and i do know what change in the code :

 

(defun c:lwsegs2arced ( / massoclst nthmassocsubst v^v unit _ilp doc lw enx gr enxb p1 p2 p3 b i n )

 (vl-load-com)

 (defun massoclst ( key lst )
   (if (assoc key lst) (cons (assoc key lst) (massoclst key (cdr (member (assoc key lst) lst)))))
 )

 (defun nthmassocsubst ( n key value lst / k slst p j plst m tst pslst )
   (setq k (length (setq slst (member (assoc key lst) lst))))
   (setq p (- (length lst) k))
   (setq j -1)
   (repeat p
     (setq plst (cons (nth (setq j (1+ j)) lst) plst))
   )
   (setq plst (reverse plst))
   (setq j -1)
   (setq m -1)
   (repeat k
     (setq j (1+ j))
     (if (equal (assoc key (member (nth j slst) slst)) (nth j slst) 1e-6)
       (setq m (1+ m))
     )
     (if (and (not tst) (= n m))
       (setq pslst (cons (cons key value) pslst) tst t)
       (setq pslst (cons (nth j slst) pslst))
     )
   )
   (setq pslst (reverse pslst))
   (append plst pslst)
 )

 (defun v^v ( u v )
   (mapcar '(lambda ( s1 s2 a b ) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u))))) '(+ - +) '(- + -) '(1 0 0) '(2 2 1))
 )

 (defun unit ( v )
   (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
 )

 (defun _ilp ( p1 p2 o nor / p1p p2p op tp pp p )
   (if (not (equal (v^v nor (unit (mapcar '- p2 p1))) '(0.0 0.0 0.0) 1e-7))
     (progn
       (setq p1p (trans p1 0 (v^v nor (unit (mapcar '- p2 p1))))
             p2p (trans p2 0 (v^v nor (unit (mapcar '- p2 p1))))
             op  (trans o 0 (v^v nor (unit (mapcar '- p2 p1))))
             op  (list (car op) (cadr op) (caddr p1p))
             tp  (polar op (+ (* 0.5 pi) (angle '(0.0 0.0 0.0) (trans nor 0 (v^v nor (unit (mapcar '- p2 p1)))))) 1.0)
       )
       (if (inters p1p p2p op tp nil)
         (progn
           (setq p (trans (inters p1p p2p op tp nil) (v^v nor (unit (mapcar '- p2 p1))) 0))
           p
         )
         nil
       )
     )
     (progn
       (setq pp (list (car (trans p1 0 nor)) (cadr (trans p1 0 nor)) (caddr (trans o 0 nor))))
       (setq p (trans pp nor 0))
       p
     )
   )
 )

 (or doc (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
 (vla-startundomark doc)
 (if (and (setq lw (entsel "\nPick LWPOLYLINE..."))
         (= (cdr (assoc 0 (setq enx (entget (car lw))))) "LWPOLYLINE")
     )
   (progn
     (setq i (fix (vlax-curve-getParamAtPoint
                 (car lw)
                 (vlax-curve-getClosestPointToProjection (car lw) (trans (cadr lw) 1 0) '(0.0 0.0 1.0))
                 ) ;_  vlax-curve-getParamAtPoint
             ) ;_  fix
          p1 (vlax-curve-getPointAtParam (car lw) i)
          p3 (vlax-curve-getPointAtParam (car lw) (1+ i))
          lw (car lw)
     )
     (setq enxb (massoclst 42 enx))
     (while (= 5 (car (setq gr (grread t))))
       (setq p2 (_ilp (trans (cadr gr) 1 0) (mapcar '+ (trans (cadr gr) 1 0) '(0.0 0.0 1.0)) p1 (cdr (assoc 210 (entget lw)))))
       (setq b ((lambda (a) (/ (sin a) (cos a)))
               (/ (- (angle (trans p2 0 lw) (trans p3 0 lw)) (angle (trans p1 0 lw) (trans p2 0 lw))) 2.0)
              )
       )
       (setq n -1)
       (foreach dxf42 enxb
         (setq n (1+ n))
         (if (= n i)
           (setq enx (nthmassocsubst n 42 b enx))
           (setq enx (nthmassocsubst n 42 (+ (cdr dxf42) b) enx))
         )
       )
       (entupd (cdr (assoc -1 (entmod enx))))
     )
   )
   (prompt "\n Nothing selected or picked object not a LWPOLYLINE ")
 )
 (vla-endundomark doc)
 (princ)
)

Share this post


Link to post
Share on other sites
hanhphuc
this lisp convert polyline segments to arcs . work one line for time . i need select 1000 polylines for times. I'm new in autolisp and i do know what change in the code :

 

another suggestion vla-setbulge method

only LWpoly

 

;another [url=";http://www.cadtutor.net/forum/showthread.php?87920-Is-there-any-routine-convert-Revcloud-to-Polyline"]old thread[/url]

(defun c:test ( / foo s i _bulge )
;hanhphuc 02.04.2018
(defun _bulge ( en n / l i ) (setq i -1 l (entget en))
 (repeat (if (zerop (cdr (assoc 70 l)))
      (1- (cdr (assoc 90 l)))
      (cdr (assoc 90 l))
      )
     (vla-setBulge (vlax-ename->vla-object en) (setq i (1+ i)) n )
     )
 )
(if
(setq ss (ssget ":L" '((0 . "LWPOLYLINE"))))
(repeat (setq i (sslength ss))
 (_bulge (ssname ss (setq i (1- i))) [color="red"][b]-0.5[/b][/color] ) [color="green"]; 0.5 or -0.5 default bulge [/color]
 )
(princ "\nLWPolyline only!")
)
(princ)
)
(vl-load-com)

 

The hiccups we don't know your LWpolylines are all in clockwise directions or else?

 

perhaps you need to filter direction, reverse & purge zero length test..

Share this post


Link to post
Share on other sites
ronjonp

Give this a try for multiple selection:

(defun c:lwsegs2arced
      (/ massoclst nthmassocsubst v^v unit _ilp d doc lw enx gr enxb p p1 p2 p3 b i n)
 (vl-load-com)
 (defun massoclst (key lst)
   (if	(assoc key lst)
     (cons (assoc key lst) (massoclst key (cdr (member (assoc key lst) lst))))
   )
 )
 (defun nthmassocsubst	(n key value lst / k slst p j plst m tst pslst)
   (setq k (length (setq slst (member (assoc key lst) lst))))
   (setq p (- (length lst) k))
   (setq j -1)
   (repeat p (setq plst (cons (nth (setq j (1+ j)) lst) plst)))
   (setq plst (reverse plst))
   (setq j -1)
   (setq m -1)
   (repeat k
     (setq j (1+ j))
     (if (equal (assoc key (member (nth j slst) slst)) (nth j slst) 1e-6)
(setq m (1+ m))
     )
     (if (and (not tst) (= n m))
(setq pslst (cons (cons key value) pslst)
      tst   t
)
(setq pslst (cons (nth j slst) pslst))
     )
   )
   (setq pslst (reverse pslst))
   (append plst pslst)
 )
 (defun v^v (u v)
   (mapcar
     '(lambda (s1 s2 a b) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u)))))
     '(+ - +)
     '(- + -)
     '(1 0 0)
     '(2 2 1)
    )
 )
 (defun unit (v) (mapcar '(lambda (x) (/ x (distance '(0.0 0.0 0.0) v))) v))
 (defun _ilp (p1 p2 o nor / p1p p2p op tp pp p)
   (if	(not (equal (v^v nor (unit (mapcar '- p2 p1))) '(0.0 0.0 0.0) 1e-7))
     (progn
(setq p1p (trans p1 0 (v^v nor (unit (mapcar '- p2 p1))))
      p2p (trans p2 0 (v^v nor (unit (mapcar '- p2 p1))))
      op  (trans o 0 (v^v nor (unit (mapcar '- p2 p1))))
      op  (list (car op) (cadr op) (caddr p1p))
      tp  (polar op
		 (+ (* 0.5 pi)
		    (angle '(0.0 0.0 0.0) (trans nor 0 (v^v nor (unit (mapcar '- p2 p1)))))
		 )
		 1.0
	  )
)
(if (inters p1p p2p op tp nil)
  (progn (setq p (trans (inters p1p p2p op tp nil) (v^v nor (unit (mapcar '- p2 p1))) 0)) p)
  nil
)
     )
     (progn (setq pp (list (car (trans p1 0 nor)) (cadr (trans p1 0 nor)) (caddr (trans o 0 nor))))
     (setq p (trans pp nor 0))
     p
     )
   )
 )
 (or doc (setq doc (vla-get-activedocument (vlax-get-acad-object))))
 (vla-startundomark doc)
 ;; RJP - added multiple selection 04.02.2018
 (if (setq s (ssget ":L" '((0 . "lwpolyline"))))
   (foreach lw	(vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
     (setq i  (fix (vlax-curve-getparamatpoint
	      lw
	      (vlax-curve-getclosestpointtoprojection
		lw
		(trans (setq p (vlax-curve-getstartpoint lw)) 1 0)
		'(0.0 0.0 1.0)
	      )
	    ) ;_  vlax-curve-getParamAtPoint
       ) ;_  fix
    p1 (vlax-curve-getpointatparam lw i)
    p3 (vlax-curve-getpointatparam lw (1+ i))
     )
     (setq enxb (massoclst 42 (setq enx (entget lw))))
     (setq p2 (_ilp (trans p 1 0)
	     (mapcar '+ (trans p 1 0) '(0.0 0.0 1.0))
	     p1
	     (cdr (assoc 210 (entget lw)))
       )
     )
     (setq
b ((lambda (a) (/ (sin a) (cos a)))
    (/ (- (angle (trans p2 0 lw) (trans p3 0 lw)) (angle (trans p1 0 lw) (trans p2 0 lw)))
       2.0
    )
  )
     )
     (setq n -1)
     (foreach dxf42 enxb
(setq n (1+ n))
(if (= n i)
  (setq enx (nthmassocsubst n 42 b enx))
  (setq enx (nthmassocsubst n 42 (+ (cdr dxf42) b) enx))
)
     )
     (entupd (cdr (assoc -1 (entmod enx))))
   )
   (prompt "\n Nothing selected or picked object not a LWPOLYLINE ")
 )
 (vla-endundomark doc)
 (princ)
)

Edited by ronjonp

Share this post


Link to post
Share on other sites
ronjonp

Same question HERE.

Share this post


Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.


×
×
  • Create New...