切割时需要Lisp程序固定乐筑天下 - Powered by Discuz! Archiver

danielk 发表于 2022-7-5 23:53:35

切割时需要口齿不清固定

我用lisp将多段线分割为指定长度的线段（加载此lisp后的MESCUT命令），
我需要的改进：
1）能够选择多个图元（交叉窗口和多重选择）
2）在随后创建的新段之间创建一个给定的间隙，但将新段保持在给定的长度。
3） 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
;; http://www.cadxp.com/sujetXForum-16753.htm
;;
;; 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 -
;; 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
)
)

pBe 发表于 2022-7-6 00:03:27

代码看起来很有趣，我稍后将对此进行研究。

顺便说一句：
请阅读代码发布指南并编辑代码以包含代码标签。

danielk 发表于 2022-7-6 00:10:02

o、 k谢谢

danielk 发表于 2022-7-6 00:10:35

任何人

marko_ribar 发表于 2022-7-6 00:17:15

也许，这可以帮助。。。

M、 R。

pBe 发表于 2022-7-6 00:21:12

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

danielk 发表于 2022-7-6 00:31:43

工作得很好！是否可以对测量命令执行类似的步骤？
非常感谢你

danielk 发表于 2022-7-6 00:35:58

很抱歉问了几次，但是可以对测量命令执行类似的过程吗？
我有很多行，这个命令可以节省我几个小时的工作

marko_ribar 发表于 2022-7-6 00:40:00

(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。

danielk 发表于 2022-7-6 00:44:58

我没有看到差距（实际上在两个LISP中），我认为autocad中发生了一些变化，因为上次它起作用了

页: [1] 2

乐筑天下's Archiver

切割时需要口齿不清固定