[编程交流] 选择多条多段线并

(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)
)

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

(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)
)