【BB】快速建块_v1.6/最小外接矩形/选择集中心

kucha007 · 发表于 2022-11-13 21:55:59

本帖最后由 kucha007 于 2023-10-29 13:00 编辑

在明经看到有人发帖问如何快速建块，手痒也折腾了一下，加了while可以循环选对象建块：http://bbs.mjtd.com/thread-186618-1-1.html

之后为了更快就想到也许可以求选择集中心点作为基点，就在论坛上翻了一下，原来已经有人这样做过了：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=178210&highlight=%BF%EC%CB%D9%2B%BF%E9

但这个插件不能在一秒内连续建块，而且最大边界框的算法在选择集较大的时候可能会出问题。选对象的时候也没有加while，批量建块速度不算快，于是我查了一下，找到了另外几个最大边界框的算法，但最后还是用lee-mac的

https://www.cadforum.cz/en/get-center-point-of-a-group-of-selected-objects-tip12403
http://www.lee-mac.com/ssboundingbox.html

；获取实体最小外接矩形的WCS坐标，来自G版：

(defun K:GetMinBox (en / p1 p2 p3 p4)
(if
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-GetBoundingBox
(list (vlax-ename->vla-object en) 'p1 'p3)
)
)
);没有捕获错误
(progn
(setq p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3)
p2 (list (car p1) (cadr p3) (caddr p1))
p4 (list (car p3) (cadr p1) (caddr p1))
)
(if (= "SPLINE" (cdr (assoc 0 (entget en))))
(progn
(setq lst (mapcar
'(lambda (a b)
(vlax-curve-getClosestPointToProjection en a b t)
)
(list p1 p2 p3 p4)
'((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
)
)
(list
(apply 'mapcar (cons 'min lst))
(apply 'mapcar (cons 'max lst))
)
)
(list p1 p3)
)
)
)
)

(defun K:GetMinBox (en / p1 p2 p3 p4) 
  (if 
    (not 
      (vl-catch-all-error-p 
        (vl-catch-all-apply 'vla-GetBoundingBox 
            (list (vlax-ename->vla-object en) 'p1 'p3) 
        ) 
      ) 
    );没有捕获错误 
    (progn 
      (setq p1 (vlax-safearray->list p1) 
            p3 (vlax-safearray->list p3) 
            p2 (list (car p1) (cadr p3) (caddr p1)) 
            p4 (list (car p3) (cadr p1) (caddr p1)) 
      ) 
      (if (= "SPLINE" (cdr (assoc 0 (entget en)))) 
        (progn 
          (setq lst (mapcar 
                      '(lambda (a b) 
                         (vlax-curve-getClosestPointToProjection en a b t) 
                       ) 
                      (list p1 p2 p3 p4) 
                      '((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0)) 
                    ) 
          ) 
          (list 
            (apply 'mapcar (cons 'min lst)) 
            (apply 'mapcar (cons 'max lst)) 
          ) 
        ) 
        (list p1 p3) 
      ) 
    ) 
  ) 
)

;选择集最小外接矩形中心点：

(defun K:GetCenter (ss / i Lst MinPt MaxPt)
(repeat (setq i (sslength ss))
(setq Lst (K:GetMinBox (ssname ss (setq i (1- i)))))
(setq
MinPt (mapcar 'min (car Lst) (cond (MinPt)((car Lst))))
MaxPt (mapcar 'max (cadr Lst) (cond (MaxPt)((cadr Lst))))
)
);获取选择集最小外接矩形的WCS坐标
(if (and MinPt MaxPt)
(mapcar
'(lambda (a b) (/ (+ a b) 2.0))
MinPt
MaxPt
)
)
)

；根据当前时间制作块名，避免跨文件块名重复：月$日时年-分秒：大概这种感觉：L$18Q22-4421
（1秒内建多个块导致块名重复就直接加数字后缀，完整逻辑见源码)

(defun K:GetBlkNam (/ K:GetTime i pre Bnam)
(defun K:GetTime (/ Old_Dim time yr mn dy hr mt sc)
(setq Old_Dim (getvar "dimzin"))
(setvar "dimzin" 0)
(setq time (rtos (getvar "cdate") 2 20))
(setq yr (substr time 3 2))
(setq mn (chr (+ 65 (read (substr time 5 2)))));转大写字母
(setq dy (substr time 7 2))
(setq hr (chr (+ 65 (read (substr time 10 2)))));转大写字母
(setq mt (substr time 12 2))
(setq sc (substr time 14 2))
(setvar "dimzin" Old_Dim)
(strcat mn "$" dy hr yr "-" mt sc )
)
(setq i 0)
(setq pre (K:GetTime));前缀
(setq Bnam Pre)
(while (tblsearch "BLOCK" Bnam)
(setq Bnam (strcat pre "-" (itoa (setq i (1+ i)))))
);查找块名避免重复
Bnam
)

;选择对象后可以通过关键词S，决定建好的块要不要放零图层（默认放当前图层）。主要代码是这两句：

(setq *ent* (entget (entlast)))
(entmod (subst (cons 8 "0") (assoc 8 *ent*) *ent*))

kucha007 · 发表于 2022-11-14 10:24:26

本帖最后由 kucha007 于 2022-11-14 21:57 编辑

想更快的话可以把选择集改为一次性选择，缺点是容易误选或者选不全

(setq ss (ssget ":L"));选择未锁定的对象，可连续多选，回车确认
(setq ss (ssget ":S"));单一选择集，只能选一次

块基点也可以改成这样，未指定时基点才使用选择集中心点：

(setq pt (getpoint "\n→请选择块基点[回车使用选择集中心点]:"))
(if pt
(setq pt (trans pt 1 0))
(setq pt (K:GetCenter ss))
)

kucha007 · 发表于 2023-2-9 00:11:36

LUX1125 发表于 2023-2-8 20:57
能在块里面快速建块吗？

块编辑器里面不能用block命令建块。建议你用粘贴为块

尘缘一生 · 发表于 2022-11-13 22:03:49

本帖最后由尘缘一生于 2022-11-13 22:06 编辑

用这个getboundingbox 函数的，毕竟需要对每一个实体，都要处理的。因为不想对全部实体处理，我也进行了探索，暂时我是这么用的。对于选择集大于10000的，我采取挖去中间，处理外围。

;返回最大外型两对角点的表 -----（一级)-------------
(defun get-box (ss / len ss1 len1 ptlis pp dis ang pt1 pt2 objlst boxlst minlst maxlst enam obj)
(defun get-ssbox (ss) ;返回集最大外框两对角点的表
(setq len (sslength ss))
(cond
((< len 500)
(setq ptlis (getpt ss 50));求点表
(setq ptlis (graham-scan ptlis)) ;高飞鸟
(if (<= (det (car ptlis) (cadr ptlis) (caddr ptlis)) 0.0)
(setq ptlis (reverse ptlis))
)
(setq pp (car (minarearectangle ptlis)));高飞鸟
(setq ptlis (get-extents pp))
)
((and (>= len 500) (< len 10000))
(setq objlst (ssget->vla-list ss))
(setq boxlst (mapcar 'get-enbox objlst))
(setq minlst (mapcar 'car boxlst))
(setq maxlst (mapcar 'cadr boxlst))
(setq ptlis (list (apply 'mapcar (cons 'min minlst)) (apply 'mapcar (cons 'max maxlst))))
)
((>= len 10000)
(command "_zoom" "_object" ss "")
(setq pp (sl_pm2pt))
(setq pt1 (car pp) pt2 (cadr pp))
(setq dis (distance pt1 pt2) ang (angle pt1 pt2) pt1 (polar pt1 ang (* 0.2 dis)) pt2 (polar pt1 ang (* 0.6 dis)))
(setq ss1 (ssget "W" pt1 pt2))
(setq ss1 (ssdiff ss ss1) len1 (sslength ss1))
(if (< len1 10000)
(get-ssbox ss1)
(progn
(command "_zoom" "_object" ss1 "")
(setq pp (sl_pm2pt))
(setq ptlis (list (car pp) (cadr pp)))
)
)
(command "_zoom" "_p")
)
)
)
;;返回对象最大外框两对角点的表---------
(defun get-enbox (nam)
(if (= (type nam) 'ENAME) (setq obj (en2obj nam)))
(vla-getboundingbox obj 'Minp 'Maxp)
(setq ptlis (mapcar 'vlax-safearray->list (list Minp Maxp)))
)
;返回点表最大外框两对角点的表
(defun get-extents (lst)
(setq ptlis (list (apply 'mapcar (cons 'min lst)) (apply 'mapcar (cons 'max lst))))
)
(cond
((= (type ss) 'PICKSET) (get-ssbox ss)) ;集
((= (type ss) 'ENAME) (get-enbox ss)) ;图元
((= (type ss) 'LIST) (get-extents ss)) ;点表
(t nil)
)
ptlis
)
;; 选择集中心点--ss 选择集----(一级)----------
(defun ssmpt (ss / ptn p5 num)
(setq num (sslength ss))
(if (< num 100)
(setq ptn (get-box ss) p5 (sl:mid (car ptn) (cadr ptn)))
(progn
(command "_zoom" "_object" ss "")
(setq p5 (getvar "viewctr"))
(command "_zoom" "_p")
)
)
p5
)

我整合的太多，无法发全。

kucha007 · 发表于 2023-1-4 11:13:08

aws 发表于 2023-1-4 09:57
你好，我意思呢，是想提取左下角和右上角的两个坐标点，所以就把后面半截省略了，但是代码跑不起来，不知 ...

把斜杆后面的lst1和lst2删掉不就行了？

(defun K:GetCenter (ss / i obj llp urp)
(repeat (setq i (sslength ss))
(setq obj (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
(if (and (vlax-method-applicable-p obj 'getboundingbox)
(not (vl-catch-all-error-p
(vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp)))
)
)
(setq ls1 (mapcar 'min (vlax-safearray->list llp) (cond (ls1) ((vlax-safearray->list llp))))
ls2 (mapcar 'max (vlax-safearray->list urp) (cond (ls2) ((vlax-safearray->list urp))))
)
)
);获取对象最大矩形边界框左下角和右上角的WCS坐标
)

mokson · 发表于 2022-11-14 07:48:22

我只能在一旁默默地观赏大佬们表演技术活！~~

Grgogo · 发表于 2022-11-14 08:08:24

厉害了，我滴哥

lxl217114 · 发表于 2022-11-14 08:37:16

楼主高产了，感谢。

海盗曹 · 发表于 2022-11-14 10:51:47

全是科技，全是狠活

中国梦 · 发表于 2022-11-14 20:46:09

楼主高产了，感谢。

酷酷提 · 发表于 2022-11-19 16:33:12

本帖最后由酷酷提于 2022-11-19 17:03 编辑

【【BB】快速建块,并移至0图层.lsp】
是我用过最符合批量建块操作逻辑的插件了
只是感觉命名规则有点乱
要是按照正常拼读顺序就最好了
比如说这样
K-2022-11-19-16-37-53

菜鸟初来乍到 · 发表于 2022-11-19 18:20:56

太强了啊，这里遍地都是大佬

账号		自动登录	找回密码
密码			注册

【BB】快速建块_v1.6/最小外接矩形/选择集中心

本帖子中包含更多资源

评分

点评