批量建块，参考前辈们的代码完成的
本帖最后由 wosiguwozai0830 于 2022-11-18 17:29 编辑;改后的代码见12楼
;批量建块,参考http://bbs.mjtd.com/forum.php?mo ... %E9&_dsign=d48aa375，作者:htlaser
(defun c:pljk( / ss qianzui blkname)
(setq qianzui(getstring"\n请输入块名的前缀:"))
(setq blkname (vl-string-subst qianzui "华星切割" (menucmd "M=$(edtime,$(getvar,date),华星切割YYYY-MO-DD-HH-MM-SS)")))
(while (setq ss(ssget))
(emkblk ss (car(ss:boundingbox ss)) blkname)
(setq ss nil)
)
(alert "批量建块完成。")
(princ)
)
;生成普通块，来源于明经论坛
(defun emkblk (ss pt name / i)
(entmake (list '(0 . "block") (cons 2 name) '(70 . 0) (cons 10 pt)))
(repeat (setq i (sslength ss)) (entmake (cdr (entget (ssname ss (setq i (1- i)))))))
(entmake '((0 . "ENDBLK")))
(command "_.erase" ss "")
(entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))
)
;选择集的包围盒,返回左上角和右下角
(defun ss:boundingbox(ss / ptb minx miny maxx maxy)
(setq ptb(mapcar '(lambda(x)(list (last(LM:boundingbox x))(cadr(LM:boundingbox x))))(sstolistf ss)))
(setq minx(apply 'min (mapcar 'caar ptb)))
(setq miny(apply 'min (mapcar '(lambda(x)(cadr(cadr x))) ptb)))
(setq maxx(apply 'max (mapcar '(lambda(x)(car(cadr x))) ptb)))
(setq maxy(apply 'max (mapcar '(lambda(x)(cadr(car x))) ptb)))
(list (list minx maxy 0)(list maxx miny))
)
;; Bounding Box-Lee Mac
;; Returns the point list describing the rectangular frame bounding the supplied object.
;; obj - VLA-Object
;图形的包围点，对矩形来说，第一点为左下角点,输入参数为图元名
(defun LM:boundingbox ( ent / obj a b lst )
(setq obj(vlax-ename->vla-object ent))
(if
(and
(vlax-method-applicable-p obj 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b))))
(setq lst (mapcar 'vlax-safearray->list (list a b)))
)
(mapcar '(lambda ( a ) (mapcar '(lambda ( b ) ((eval b) lst)) a))
'(
(caar cadar)
(caadrcadar)
(caadr cadadr)
(caarcadadr)
)
)
)
)
;将选择集转换成图元名表,参数选择集
(defun sstolistf(ss)
(vl-remove-if 'listp (mapcar 'cadr (ssnamexss)))
)
本帖最后由 wosiguwozai0830 于 2022-11-18 13:15 编辑
行天下 发表于 2022-11-18 13:03
能改成中点吗，左上角个人感觉没有意义
需要中点的话，将 (emkblk ss (car(ss:boundingbox ss)) blkname)改为
(emkblk ss (cl:midpt(car(ss:boundingbox ss))(cadr(ss:boundingbox ss)) 0 0) blkname)
;两点的中点，加上偏移参数
(defun cl:midpt(pt1 pt2 xpy ypy )
(list (+ (/ (+ (car pt1) (car pt2)) 2.0) xpy) (+ (/ (+(cadr pt1) (cadr pt2)) 2.0) ypy) 0)
)
修改了下，之前块名有问题
本帖最后由 wosiguwozai0830 于 2022-11-18 17:24 编辑;批量建块,参考http://bbs.mjtd.com/forum.php?mo ... %E9&_dsign=d48aa375，作者:htlaser
(defun c:pljk( / ss qianzui blkname)
(setq qianzui(getstring"\n请输入块名的前缀:"))
(while (setq ss(ssget))
(setq blkname (vl-string-subst qianzui "华星切割" (menucmd "M=$(edtime,$(getvar,date),华星切割YYYY-MO-DD-HH-MM-SS)")))
(emkblk ss (car(ss:boundingbox ss)) blkname)
(setq ss nil)
)
(alert "批量建块完成。")
(princ)
)
;生成普通块，来源于明经论坛
(defun emkblk (ss pt name / i)
(entmake (list '(0 . "block") (cons 2 name) '(70 . 0) (cons 10 pt)))
(repeat (setq i (sslength ss)) (entmake (cdr (entget (ssname ss (setq i (1- i)))))))
(entmake '((0 . "ENDBLK")))
(command "_.erase" ss "")
(entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))
)
;选择集的包围盒,返回左上角和右下角
(defun ss:boundingbox(ss / ptb minx miny maxx maxy)
(setq ptb(mapcar '(lambda(x)(list (last(LM:boundingbox x))(cadr(LM:boundingbox x))))(sstolistf ss)))
(setq minx(apply 'min (mapcar 'caar ptb)))
(setq miny(apply 'min (mapcar '(lambda(x)(cadr(cadr x))) ptb)))
(setq maxx(apply 'max (mapcar '(lambda(x)(car(cadr x))) ptb)))
(setq maxy(apply 'max (mapcar '(lambda(x)(cadr(car x))) ptb)))
(list (list minx maxy 0)(list maxx miny))
)
;; Bounding Box-Lee Mac
;; Returns the point list describing the rectangular frame bounding the supplied object.
;; obj - VLA-Object
;图形的包围点，对矩形来说，第一点为左下角点,输入参数为图元名
(defun LM:boundingbox ( ent / obj a b lst )
(setq obj(vlax-ename->vla-object ent))
(if
(and
(vlax-method-applicable-p obj 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b))))
(setq lst (mapcar 'vlax-safearray->list (list a b)))
)
(mapcar '(lambda ( a ) (mapcar '(lambda ( b ) ((eval b) lst)) a))
'(
(caar cadar)
(caadrcadar)
(caadr cadadr)
(caarcadadr)
)
)
)
)
;将选择集转换成图元名表,参数选择集
(defun sstolistf(ss)
(vl-remove-if 'listp (mapcar 'cadr (ssnamexss)))
)
谢谢分享
贴主辛苦 错误: no function definition: SSTOLISTF 行天下 发表于 2022-11-18 11:38
错误: no function definition: SSTOLISTF
已上传，在代码最后最后面 看到了，谢谢分享 wosiguwozai0830 发表于 2022-11-18 11:39
已上传，在代码最后最后面
能改成中点吗，左上角个人感觉没有意义 wosiguwozai0830 发表于 2022-11-18 13:13
需要中点的话，将 (emkblk ss (car(ss:boundingbox ss)) blkname)改为
(emkblk ss (cl:midpt(car(ss:bou ...
谢谢大佬的分享，感谢 :handshake:handshake:handshake:handshake 本帖最后由 kucha007 于 2022-11-18 16:42 编辑
巧了，我前两天刚搞了一个，互相学习哈哈。http://bbs.mjtd.com/thread-186619-1-1.html
不知道是不是我的问题，试了一下建块后没有退出循环，我还以为可以批量建立，但似乎块名重复了，后面建的块覆盖了前面的块。
而且都批量建块了，是不是取消需要输入前缀更快一些～另外最后的弹窗还需要手动叉掉，如果没有特殊的原因是否打印在命令行更好？