[编程交流] 等距分割多段线

(defun c:divplsegs+vtxs ( / add_vtx trunc clean_poly ss ssh mind i pl ep k j dk dj d n dd m p ptlst )
 (vl-load-com)
 (defun add_vtx ( obj add_pt ent_name / bulg )
     (vla-addVertex
         obj
         (1+ (fix add_pt))
         (vlax-make-variant
             (vlax-safearray-fill
                 (vlax-make-safearray vlax-vbdouble (cons 0 1))
                     (list
                         (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                         (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                     )
             )
         )
     )
     (setq bulg (vla-GetBulge obj (fix add_pt)))
     (vla-SetBulge obj
         (fix add_pt)
         (/
             (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
             (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
         )
     )
     (vla-SetBulge obj
         (1+ (fix add_pt))
         (/
             (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
             (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
         )
     )
     (vla-update obj)
 )
 (defun trunc ( expr lst )
   (if (and lst
      (not (equal (car lst) expr))
       )
     (cons (car lst) (trunc expr (cdr lst)))
   )
 )
 (defun clean_poly ( ent / e_lst p_lst vtx1 vtx2 )
   (setq e_lst (entget ent))
   (cond
     ((= "LWPOLYLINE" (cdr (assoc 0 e_lst)))
      (setq p_lst (vl-remove-if-not
        '(lambda (x)
           (or (= (car x) 10)
         (= (car x) 40)
         (= (car x) 41)
         (= (car x) 42)
           )
         )
        e_lst
      )
      e_lst (vl-remove-if
        '(lambda (x)
           (member x p_lst)
         )
        e_lst
      )
      )
      (if (= 1 (cdr (assoc 70 e_lst)))
        (while (equal (car p_lst) (assoc 10 (reverse p_lst)))
    (setq p_lst (reverse (cdr (member (assoc 10 (reverse p_lst))
              (reverse p_lst)
            )
             )
          )
    )
        )
      )
      (while p_lst
        (setq e_lst (append e_lst (trunc (assoc 10 (cdr p_lst)) p_lst))
        p_lst (member (assoc 10 (cdr p_lst)) (cdr p_lst))
        )
      )
      (entmod e_lst)
     )
     ((and (= "POLYLINE" (cdr (assoc 0 e_lst)))
     (zerop (logand 240 (cdr (assoc 70 e_lst))))
      )
      (setq e_lst (cons e_lst nil)
      vtx1     (entnext ent)
      vtx2     (entnext vtx1)
      )
      (while (= (cdr (assoc 0 (entget vtx1))) "VERTEX")
        (if (= (cdr (assoc 0 (entget vtx2))) "SEQEND")
    (if
      (or (not
      (equal    (assoc 10 (entget vtx1))
       (assoc 10 (last (reverse (cdr (reverse e_lst)))))
      )
          )
          (zerop (logand 1 (cdr (assoc 70 (last e_lst)))))
      )
       (setq e_lst (cons (entget vtx1) e_lst))
    )
    (if
      (not
        (equal (assoc 10 (entget vtx1)) (assoc 10 (entget vtx2)) 1e-9)
      )
       (setq e_lst (cons (entget vtx1) e_lst))
    )
        )
        (setq vtx1 vtx2
        vtx2 (entnext vtx1)
        )
      )
      (setq e_lst (reverse (cons (entget vtx1) e_lst)))
      (entdel ent)
      (mapcar 'entmake e_lst)
     )
     (T (princ "\nEntité non valide."))
   )
   (princ)
 )
 (prompt "\nSelect 2d polylines...")
 (setq ss (ssget "_:L" '((0 . "*POLYLINE") (-4 . "<not") (-4 . "&=") (70 .  (-4 . "not>"))))
 (setq ssh (ssadd))
 (initget 7)
 (setq mind (getdist "\nSpecify min. distance for segments division: "))
 (setq i -1)
 (while (setq pl (ssname ss (setq i (1+ i))))
   (if (eq (cdr (assoc 0 (entget pl))) "POLYLINE")
     (progn
       (command "_.convertpoly" "_l" pl "")
       (ssadd pl ssh)
     )
   )
   (setq ep (vlax-curve-getendparam pl))
   (setq k -1.0)
   (while (< (setq k (1+ k)) ep)
     (setq j (1+ k))
     (setq dk (vlax-curve-getdistatparam pl k))
     (setq dj (vlax-curve-getdistatparam pl j))
     (setq d (- dj dk))
     (setq n (fix (/ d mind)))
     (if (> n 1)
       (progn
         (setq dd (/ d (float n)))
         (setq m -1.0)
         (repeat n
           (setq p (vlax-curve-getpointatdist pl (+ dk (* dd (setq m (1+ m))))))
           (entmake (list '(0 . "POINT") (cons 10 p)))
           (setq ptlst (cons p ptlst))
         )
       )
       (progn
         (setq p (vlax-curve-getpointatdist pl dk))
         (entmake (list '(0 . "POINT") (cons 10 p)))
         (setq ptlst (cons p ptlst))
       )
     )
   )
   (entmake (list '(0 . "POINT") (cons 10 (vlax-curve-getendpoint pl))))
   (setq ptlst (cons p ptlst))
   (foreach p (reverse ptlst)
     (vl-catch-all-apply 'add_vtx (list (vlax-ename->vla-object pl) (vlax-curve-getparamatpoint pl (vlax-curve-getclosestpointto pl p)) pl))
   )
   (setq ptlst nil)
   (clean_poly pl)
 )
 (setq i -1)
 (while (setq pl (ssname ssh (setq i (1+ i))))
   (command "_.convertpoly" "_h" pl "")
 )
 (princ)
)