Jump to content

need a lisp fixing for cutting a polilines into segments

danielk

By danielk
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

danielk Community Regular

danielk

Posted
Posted (edited)

i have this lisp dividing a polylines to segments (MESCUT command after loading this lisp ) at a specified length ,

the improvements i need :

1) the ability to select more then one entity ( crossing window and multiple selection)

2) to create a given gap between the new segments then being created but keeping the new segments at a given length.

3) the lisp should remember the last details i entered for next time until i decide to change it .

 

Thanks again for all the geniuses out there,:D

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

Edited by danielk
Link to comment
Share on other sites
  • 3 weeks later...
pBe Grand Master

pBe

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

Link to comment
Share on other sites
danielk Community Regular

danielk

Posted
  • Author
Posted 
(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)

working great! :D is it possible to make a similar procedure for the MEASURE command ?

thank you so much

Link to comment
Share on other sites
danielk Community Regular

danielk

Posted
  • Author
Posted

sorry for asking couple of times but is it possible to make a similar procedure for the MEASURE command ?

i have tons of lines and this command will save me hours of work

Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

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

HTH, M.R.

Link to comment
Share on other sites
danielk Community Regular

danielk

Posted
  • Author
Posted 
(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)

HTH, M.R.

 

I Dont see the gap , (actually in both of the lisps ), i think something changed in autocad , beacuse last time it worked

Link to comment
Share on other sites
  • 2 weeks later...

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...