jntm226 发表于 2022-7-5 15:24:43

选择多条多段线并

此lisp将多段线线段转换为圆弧。一次只做一行。我需要为次选择1000条多段线。我是autolisp新手，我知道代码中有什么变化：
 
(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)
)

hanhphuc 发表于 2022-7-5 16:01:00

 
另一种建议vla setbulge方法
仅LWpoly
 

;another old thread

(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))) -0.5 ) ; 0.5 or -0.5 default bulge
)
(princ "\nLWPolyline only!")
)
(princ)
)
(vl-load-com)

 
我们不知道你们的LW多段线都是顺时针方向还是其他方向？
 
也许您需要过滤方向、反转和清除零长度测试。。

ronjonp 发表于 2022-7-5 16:11:15

尝试多种选择：
(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)
)

ronjonp 发表于 2022-7-5 16:39:54

同样的问题。
页: [1]
查看完整版本: 选择多条多段线并