[编程交流] 切割时需要Lisp程序固定

;; Deux petites routines pour tronחonner des objets curvilignes 
;; (arc, cercle, ellipse, ligne, polylignes, et spline) 
;; soit en un nombre spיcifiי de tronחons : DivCut, 
;; soit en des tronחons d'une longueur spיcifiיe : MesDiv
;; [url]http://www.cadxp.com/sujetXForum-16753.htm[/url] 
;;
;; 2 commandes: DIVCUT & MESCUT
;;
;; EDIT : NOUVELLE VERSION, l'ancienne ne fonctionnait pas 
;; avec les polylignes 2D et 3D, ni avec les polylignes fermיes
;;;;;;;;;
;; DIVCUT - [Editי le 17/9/2007 par (gile)]
;; Coupe l'objet sיlectionnי en le nombre spיcifiי de tronחons יgaux
;;;;;;;;;
(defun c:divcut (/ ent end div len elst)
(vl-load-com)
(if
(and
(setq ent (car (entsel)))
(not (vl-catch-all-error-p
(setq end
(vl-catch-all-apply 'vlax-curve-getEndParam (list ent))
)
)
)
(princ
(strcat "\nLongueur de l'objet : "
(rtos (setq len (vlax-curve-getDistAtParam ent end)))
)
)
(setq div (getint "\nNombre de divisions: "))
(< 0 div)
(setq len (/ len div))
)
(progn
(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
(repeat (1- div)
(setq
ent
(cadr
(CutCurveAtPoint ent (vlax-curve-getPointAtDist ent len))
)
)
)
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(princ "\nEntitי non valide")
)
(princ)
)
;;;;;;;;;
;; MESCUT
;; Coupe l'objet sיlectionnי en tronחons de la longueur spיcifiיe
;;;;;;;;;
(defun c:mescut (/ ent end tot len div elst)
(vl-load-com)
(if
(and
(setq ent (car (entsel)))
(not (vl-catch-all-error-p
(setq end
(vl-catch-all-apply 'vlax-curve-getEndParam (list ent))
)
)
)
(princ
(strcat "\nLongueur de l'objet : "
(rtos (setq tot (vlax-curve-getDistAtParam ent end)))
)
)
(setq len (getdist "\nLongueur du segment: "))
(< 0 len)
(setq div (fix (/ tot len)))
)
(progn
(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
(repeat div
(setq
ent
(cadr
(CutCurveAtPoint ent (vlax-curve-getPointAtDist ent len))
)
)
)
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(princ "\nEntitי non valide")
)
(princ)
) 
;; Coupe un objet curviligne au point spיcifiי
;;
;; Arguments
;; ent : l'objet א couper (ename ou vla-object)
;; pt : le point de coupure (coordonnיes WCS)
;;
;; Retour
;; une liste des deux objets crייs (ename ou vla-object)
(defun CutCurveAtPoint (ent pt / vl lst cl start end ec os)
(vl-load-com)
(and (= (type ent) 'VLA-OBJECT)
(setq ent (vlax-vla-object->ename ent)
vl T
)
)
(cond
((equal pt (vlax-curve-getEndPoint ent) 1e-9)
(setq lst (list ent nil))
)
((equal pt (vlax-curve-getStartPoint ent) 1e-9)
(setq lst (list nil ent))
)
((null (vlax-curve-getParamAtPoint ent pt))
(setq lst (list ent nil))
)
(T
(setq start (trans (vlax-curve-getStartPoint ent) 0 1)
end (trans (vlax-curve-getEndPoint ent) 0 1)
ec (getvar "cmdecho")
os (getvar "osmode")
)
(setvar "cmdecho" 0)
(setvar "osmode" 0)
(if (and (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE")
(= 1 (logand 1 (cdr (assoc 70 (entget ent)))))
)
(progn
(command "_.break" ent (trans pt 0 1) "@")
(setq cl (entlast))
)
(progn
(if (= "POLYLINE" (cdr (assoc 0 (entget ent))))
(progn
(entmake (entget ent))
(setq vx (entnext ent))
(while (= "VERTEX" (cdr (assoc 0 (entget vx))))
(entmake (entget vx))
(setq vx (entnext vx))
)
(entmake '((0 . "SEQEND")))
(setq cl (entlast)
po T
)
)
(setq cl (entmakex (entget ent)))
)
(command "_.break" ent (trans pt 0 1) end)
(and po (setq ent (entlast)))
(command "_.break" cl start (trans pt 0 1))
(and po (setq cl (entlast)))
)
)
(setvar "cmdecho" ec)
(setvar "osmode" os)
(setq lst (list ent cl))
)
)
(if vl
(mapcar '(lambda (x)
(if x
(vlax-ename->vla-object x)
)
)
lst
)
lst
)
)                  

(defun c:moveseg (/ ss i e d ang pre dst)
;;;                pBe 17Nov2013                ;;;
(if (setq ss (ssget '((0 . "LWPOLYLINE,LINE"))))
   (progn
(setq seg (cond
((getint (strcat "\nEnter number of segments:"
         (if seg (strcat " <" (itoa seg) ">: ") ": ")
                    )))(seg))
        )
(setq gap (cond
((getdist (strcat "\nEnter value for gap:"
         (if gap (strcat " <" (rtos gap) ">: ") ": ")
                    )))(gap))
        )
     (repeat (setq i (sslength ss))
(setq pre (ssadd) e (ssname ss (setq i (1- i))))
(setq dst
       (/ (vlax-curve-getdistatparam e (vlax-curve-getendparam e))
          seg
       )
)
(repeat        seg
  (setq pt (vlax-curve-getpointatdist e dst))
  (setq        ang (angle '(0.0 0.0 0.0)
                   (vlax-curve-getfirstderiv
                     e
                     (vlax-curve-getparamatpoint e pt)
                   )
            )
  )
  (command "_break" e "_non" pt "_non" pt)
  (ssadd e pre)
  (command "_move"
           pre
           ""
           "_non"
           pt
           (polar pt (+ pi ang) gap)
  )(setq e (entlast))
)
     )
   )
 )
 (princ)
)
(vl-load-com)

(defun c:moveseg2 (/ ss i e ang pre)
;;;        MR 24Nov2013        ;;;
 (if (setq ss (ssget '((0 . "LWPOLYLINE,LINE"))))
   (progn
     (setq d (cond
               ((getdist (strcat "\nEnter or pick measure distance"
                                 (if d
                                   (strcat " <" (rtos d) ">: ")
                                   ": "
                                 )
                         )
                )
               )
               (d)
             )
     )
     (setq gap (cond
                 ((getdist (strcat "\nEnter value for gap"
                                   (if gap
                                     (strcat " <" (rtos gap) ">: ")
                                     ": "
                                   )
                           )
                  )
                 )
                 (gap)
               )
     )
     (repeat (setq i (sslength ss))
       (setq pre (ssadd)
             e   (ssname ss (setq i (1- i)))
       )
       (repeat
         (fix
           (/ (vlax-curve-getdistatparam e (vlax-curve-getendparam e))
              d
           )
         )
          (setq pt (vlax-curve-getpointatdist e d))
          (setq ang (angle '(0.0 0.0 0.0)
                           (vlax-curve-getfirstderiv
                             e
                             (vlax-curve-getparamatpoint e pt)
                           )
                    )
          )
          (command "_break" e "_non" pt "_non" pt)
          (ssadd e pre)
          (command "_move"
                   pre
                   ""
                   "_non"
                   pt
                   (polar pt (+ pi ang) gap)
          )
          (setq e (entlast))
       )
     )
   )
 )
 (princ)
)
(vl-load-com)