如何批量修剪？

zilong136

如下图所示，想让1批量修剪成2，三领的综合修剪可以，但不知道是不是我CAD的问题还是怎么的，这个命令现在不能用，求能实现该功能的Lisp?谢谢。

统一网名

(defun c:tt (/ a b ename i len lst pts ss dx1)
        (setq ss (ssget '((0 . "LINE"))))
        (setq i 0)
        (setq len (sslength ss))                        
        (repeat len
    (setq pts nil)               
                (setq ename (ssname ss i))
                (setq a (cdr (assoc 10 (entget ename))))
                (setq b (cdr (assoc 11 (entget ename))))
                (setq pts (cons a pts))
                (setq pts (cons b pts))
                (get-zxssjd ss ename);找出交点
                (if(< i (/ len 2))
                        (setq lst (vl-sort pts (function (lambda (e1 e2)(< (car e1) (car e2))))))
                        (setq lst (vl-sort pts (function (lambda (e1 e2)(< (cadr e1) (cadr e2))))))
                );排序
                (chzx lst);重画直线               
                (setq i (+ i 1))
        )
        (command "erase" ss "");删除原有直线
        (princ)
)
;ss 选择集 , dx1 指定直线
;输出 pts 交点点表
(defun get-zxssjd (ss dx1 /  dx2 jd i L)
        (setq a (cdr (assoc 10 (entget dx1))))
        (setq b (cdr (assoc 11 (entget dx1))))
        (setq i (sslength ss))
        (setq L 0)        
        (repeat i
                (setq dx2 (ssname ss L));设置 dx2
                (setq jd  (vlax-invoke (vlax-ename->vla-object dx2) 'IntersectWith (vlax-ename->vla-object dx1) acExtendNone))        
                (if (and(not (null jd))(not (member jd pts)))
                        (setq pts (cons jd pts))
                );有点对象没有交点，当有交点时把交点加入到点表               
                (if (not (member a pts))(setq pts (cons a pts)))
                (if (not (member b pts))(setq pts (cons b pts)))
                (setq L (+ L 1))               
        )               
)

;重画直线
(defun chzx (lst / a b i l)
        (setq i 0 )
        (repeat (/(length lst)2)
                (setq l (+ i 1))
                (setq a (nth i lst))
                (setq b (nth l lst))
                (entmake (list '(0 . "LINE") (cons 10 a) (cons 11 b)(cons 62 1)))
                (setq i ( + i 2))
        )                                                
)

统一网名

zilong136 发表于 2024-9-10 01:45
你没听懂我的意思，我是说如何写一个LISP,可以一键生成这些矩形小方格

• (defun c:tt (/ dzl dzl2 hcs hdzl jj jx1c jx1k jx2c jx2k lsqd p0 qd scs sdzl)  
•   (setq
•     jx1c 240 jx1k 240 ;矩形区域的长、宽
•     jx2c 4  jx2k 4 ;画小矩形的长、宽
•     jj 20 ;间距
•   );该部分可以更改为对话框
•   (setq dzl2 0)
•   (setq hdzl (+ jx2c jj))
•   (setq sdzl (+ jx2k jj))
•   (setq hcs (fix (/ jx1c hdzl)))
•   (setq scs (fix (/ jx1k sdzl)))
•   (setq p0 (getpoint "\n点选起点:"))
•   (repeat scs
•     (setq lsqd (list(car p0)(-(cadr p0)dzl2)))
•     (setq dzl 0)
•     (repeat hcs
•       (setq qd (list(+(car lsqd)dzl)(cadr lsqd)))
•       (huajuxing qd jx2c jx2k)
•       (setq dzl (+ dzl hdzl))
•     )
•     (setq dzl2 (+ dzl2 sdzl))
•   )
• )
• (defun huajuxing(qd cd kd / djd )
•   (setq djd (list(+(car qd)cd)(-(cadr qd)kd)));左上 右下画矩形
•   (command "rectang" "non" qd "non" djd);画矩形
• )
  

lzspain

看一下大佬lee50310的程序http://bbs.mjtd.com/thread-191020-1-1.html

zilong136

lzspain 发表于 2024-9-8 16:42
看一下大佬lee50310的程序http://bbs.mjtd.com/thread-191020-1-1.html

我去下载了，但还是不能用，就最外框合并了一下。

lzspain

zilong136 发表于 2024-9-8 17:01
我去下载了，但还是不能用，就最外框合并了一下。

谜你工具箱有这个功能，你可以了解一下。

飞雪神光

还有一个思路是 交点打断 或交点重生成 删除长度小于设定值得线

zilong136

lzspain 发表于 2024-9-8 17:23
谜你工具箱有这个功能，你可以了解一下。

哪个命令，还请明示

lzspain

zilong136 发表于 2024-9-8 19:53
哪个命令，还请明示

修补双线，，，，，，，

bai2000

同意5楼意见，这样更简单

lzspain

飞雪神光 发表于 2024-9-8 19:52
还有一个思路是 交点打断 或交点重生成 删除长度小于设定值得线

我有时候就是用RBD这样做的，就是没有谜你快

hubeiwdlue

飞雪神光 发表于 2024-9-8 19:52
还有一个思路是 交点打断 或交点重生成 删除长度小于设定值得线

这个思路好，交点打断，现在都是用command吗，还有别的方法吗？