[编程交流] 将直线分解为线段

(command "_.explode" [color=red]([/color]entlast[color=red])[/color] "")

(defun plintav ( / intersobj1obj2 LM:Unique AT:GetVertices _reml member-fuzz add_vtx
                  ss sslpl sshpl i ent n ent1 ss-ent1 k ent2 intpts intptsall pl plpts restintpts par )
 (vl-load-com)
 (defun intersobj1obj2 ( obj1 obj2 / coords pt ptlst )
   (if (eq (type obj1) 'ENAME) (setq obj1 (vlax-ename->vla-object obj1)))
   (if (eq (type obj2) 'ENAME) (setq obj2 (vlax-ename->vla-object obj2)))
   (setq coords (vl-catch-all-apply 'vlax-safearray->list (list (vl-catch-all-apply 'vlax-variant-value (list (vla-intersectwith obj1 obj2 AcExtendNone))))))
   (if (vl-catch-all-error-p coords)
     (setq ptlst nil)
     (repeat (/ (length coords) 3)
       (setq pt (list (car coords) (cadr coords) (caddr coords)))
       (setq ptlst (cons pt ptlst))
       (setq coords (cdddr coords))
     )
   )
   ptlst
 )  
 (defun LM:Unique ( lst )
   (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
 )
 (defun AT:GetVertices ( e / p l )
   (LM:Unique
     (if e
       (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
         (repeat (setq p (1+ (fix p)))
           (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
         )
         (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e))
       )
     )
   )
 )
 (defun _reml ( l1 l2 / a n ls )
   (while 
     (setq n nil 
           a (car l2)
     )
     (while (and l1 (null n))
       (if (equal a (car l1) 1e-
         (setq l1 (cdr l1) 
               n t
         )
         (setq ls (append ls (list (car l1)))
               l1 (cdr l1)
         )
       )
     )
     (setq l2 (cdr l2))
   )
   (append ls l1)
 )
 (defun member-fuzz ( expr lst fuzz )
   (while (and lst (not (equal (car lst) expr fuzz)))
     (setq lst (cdr lst))
   )
   lst
 )
 (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)
 )
 (setq ss (ssget "_I" '((0 . "*POLYLINE") (-4 . "<and") (-4 . "<not") (-4 . "&=") (70 .  (-4 . "not>") (-4 . "<") (70 . 130) (-4 . "and>"))))
 (setq sslpl (ssadd) sshpl (ssadd))
 (setq i -1)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (if (eq (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
     (progn
       (entupd ent)
       (vla-update (vlax-ename->vla-object ent))
       (ssadd ent sslpl)
     )
   )
   (if (eq (cdr (assoc 0 (entget ent))) "POLYLINE")
     (ssadd ent sshpl)
   )
 )
 (setq i -1)
 (while (setq ent (ssname sshpl (setq i (1+ i))))
   (command "_.convertpoly" "l" ent "")
   (entupd ent)
   (vla-update (vlax-ename->vla-object ent))
   (ssadd ent sslpl)
 )
 (repeat (setq n (sslength ss))
   (setq ent1 (ssname ss (setq n (1- n))))
   (setq ss-ent1 (ssdel ent1 ss))
   (repeat (setq k (sslength ss-ent1))
     (setq ent2 (ssname ss-ent1 (setq k (1- k))))
     (setq intpts (intersobj1obj2 ent1 ent2))
     (setq intptsall (append intpts intptsall))
   )
 )
 (setq i -1)
 (while (setq pl (ssname sslpl (setq i (1+ i))))
   (setq plpts (AT:GetVertices pl))
   (setq restintpts (_reml intptsall plpts))
   (foreach pt restintpts
     (if 
       (and
         (not (member-fuzz pt plpts 1e-6))
         (setq par (vlax-curve-getparamatpoint pl pt))
       )
       (add_vtx (vlax-ename->vla-object pl) par pl)        
     )
   )
 )
 (setq i -1)
 (while (setq ent (ssname sshpl (setq i (1+ i))))
   (command "_.convertpoly" "h" ent "")
 )
 (princ)
)
(defun c:test (/ pea qaf ss sspl ssli i ent)
 (setq pea (getvar "PEDITACCEPT"))
 (setq qaf (getvar "QAFLAGS"))
 (if (setq ss (ssget '((0 . "ARC,*POLYLINE,LINE"))))
   (progn
     (setq sspl (ssadd))
     (setq ssli (ssadd))
     (setq i -1)
     (while (setq ent (ssname ss (setq i (1+ i))))
       (if (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE")
         (ssadd ent sspl)
         (progn
           (setvar "PEDITACCEPT" 1)
           (command "_.pedit" ent "")
           (ssadd (entlast) ssli)
         )
       )
     )
   )
 )
 (sssetfirst nil (acet-ss-union (list ssli sspl)))
 (plintav)
 (setvar "QAFLAGS" 1)
 (command "_.explode")
 (setvar "QAFLAGS" qaf)
 (setvar "PEDITACCEPT" pea)
 (princ)
)