【BB】快速建块_v1.6/最小外接矩形/选择集中心
本帖最后由 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: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 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))
)
LUX1125 发表于 2023-2-8 20:57
能在块里面快速建块吗？
块编辑器里面不能用block命令建块。建议你用粘贴为块 本帖最后由 尘缘一生 于 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
[*])
我整合的太多，无法发全。
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坐标
)
我只能在一旁默默地观赏大佬们表演技术活！~~ 厉害了，我滴哥 楼主高产了，感谢。 全是科技，全是狠活 楼主高产了，感谢。 本帖最后由 酷酷提 于 2022-11-19 17:03 编辑
【【BB】快速建块,并移至0图层.lsp】
是我用过最符合批量建块操作逻辑的插件了
只是感觉命名规则有点乱
要是按照正常拼读顺序就最好了
比如说这样
K-2022-11-19-16-37-53
太强了啊，这里遍地都是大佬