[原创]快速制作带序号的图块lisp

edata

最近要批量做些带序号的块，简单的做了个LISP程序。
自己用，写的简单，实用为主。
希望论坛的高人给指点指点。

2. ;功能：制作带序号的图块，图形为转换为块模式。
3. ;命令：SB 需要选择插入点. 命令 SB2 默认插入基点在选择图形的左下角.
4. ;命令：RSB 重设块名及序号.首次运行SB或SB2会要求设置.
5. ;The code by edata bbs.mjtd.com 2010年6月27日20:48:16
6. ;注意：选择图形不能为空，否则将循环选择，可以按ESC退出.
7. (defun c:sb2(/ pt1 pt2 en pt_list ssblock1)
8. (while (= ssblock1 nil) ;选择图形，如为空则需要重新选择.
9. (setq ssblock1(ssget))
10. )
11. (setq pt_list '());开始计算选择的图形左下角点.
12. (setq sn (sslength ssblock1))
13. (setq n -1)
14. (repeat sn
15. (setq en (ssname ssblock1 (setq n (1+ n))))
16. (vla-getboundingbox (vlax-ename->vla-object en) 'pt1 'pt2)
17. (setq pt_list (cons (vlax-safearray->list pt1) pt_list))
18. ;(setq pt_list (cons (vlax-safearray->list pt2) pt_list))
19. )
20. (setq pt1 (apply 'mapcar (cons 'min pt_list)))
21. ;(setq pt2 (apply 'mapcar (cons 'max pt_list))) ;右上角点
22. (sk_bname1);调用获得图块名称函数.
23. (sk_makeblock1);调用制作图块函数.
24. (princ)
26. (prin1)
27. )
28. ;程序主体需要指定基点
29. (defun c:sb(/ pt1 ssblock1)
31. (princ "\n<RSB>按RSB键重新设置参数")
32. (while (= ssblock1 nil)
33. (setq ssblock1(ssget)
34.     pt1 (getpoint "\n请选择插入点：")
35.     )
36. )
39. (sk_bname1)
40. (sk_makeblock1)
41. (princ)
43. )
44. ;提示输入块名前缀函数
45. (defun sk_bname1();获得块名函数
47. (if (or (= sk_blocknamex1 nil)(= sk_blocknamex1 ""))
48. (setq sk_blocknamex1 (getstring "\n请输入块名前缀：")))
49. (if (= sk_num1 nil)
50. (progn
51. (setq sk_num1 (getint "\n请输入序号" ))
52. (if (= sk_num1 nil) (setq sk_num1 0))))
53. (if (= blockname1 nil) (setq blockname1 (strcat sk_blocknamex1 (rtos sk_num1))))
54. (while (/= (tblobjname "block" blockname1) nil)
55. (setq sk_num1 (+ sk_num1 1))
56. (setq blockname1 (strcat sk_blocknamex1 (rtos sk_num1))))
57. (princ)
58. )
60. ;做块函数
61. (defun sk_makeblock1();制作块函数部分
62. (if
63. (= (tblobjname "block" blockname1) nil)
64. (progn
65. (command "-block" blockname1 pt1 ssblock1 "")
67. (command "-insert" blockname1 pt1 "" "" "")
68. (princ (strcat "\n!!!成功制作新块< " blockname1" >!!!!"))
69. )
70. )
71. (princ)
72. )
73. ;重置块名设置
74. (defun c:rsb();重置块主函数
75. (setq sk_num1 nil
76.     sk_blocknamex1 nil)
77. (sk_bname1)
78. (princ "\n 设置成功,请重新运行程序")
80. (princ)
82. )
83. (PRINC "\n SB 启动程序")

;功能：制作带序号的图块，图形为转换为块模式。 ;命令：SB 需要选择插入点. 命令 SB2 默认插入基点在选择图形的左下角. ;命令：RSB 重设块名及序号.首次运行SB或SB2会要求设置. ;The code by edata bbs.mjtd.com 2010年6月27日20:48:16 ;注意：选择图形不能为空，否则将循环选择，可以按ESC退出. (defun c:sb2(/ pt1 pt2 en pt_list ssblock1) (while (= ssblock1 nil) ;选择图形，如为空则需要重新选择. (setq ssblock1(ssget)) ) (setq pt_list '());开始计算选择的图形左下角点. (setq sn (sslength ssblock1)) (setq n -1) (repeat sn (setq en (ssname ssblock1 (setq n (1+ n)))) (vla-getboundingbox (vlax-ename->vla-object en) 'pt1 'pt2) (setq pt_list (cons (vlax-safearray->list pt1) pt_list)) ;(setq pt_list (cons (vlax-safearray->list pt2) pt_list)) ) (setq pt1 (apply 'mapcar (cons 'min pt_list))) ;(setq pt2 (apply 'mapcar (cons 'max pt_list))) ;右上角点 (sk_bname1);调用获得图块名称函数. (sk_makeblock1);调用制作图块函数. (princ) (prin1) ) ;程序主体需要指定基点 (defun c:sb(/ pt1 ssblock1) (princ "\n<RSB>按RSB键重新设置参数") (while (= ssblock1 nil) (setq ssblock1(ssget)     pt1 (getpoint "\n请选择插入点：")     ) ) (sk_bname1) (sk_makeblock1) (princ) ) ;提示输入块名前缀函数 (defun sk_bname1();获得块名函数 (if (or (= sk_blocknamex1 nil)(= sk_blocknamex1 "")) (setq sk_blocknamex1 (getstring "\n请输入块名前缀："))) (if (= sk_num1 nil) (progn (setq sk_num1 (getint "\n请输入序号" )) (if (= sk_num1 nil) (setq sk_num1 0)))) (if (= blockname1 nil) (setq blockname1 (strcat sk_blocknamex1 (rtos sk_num1)))) (while (/= (tblobjname "block" blockname1) nil) (setq sk_num1 (+ sk_num1 1)) (setq blockname1 (strcat sk_blocknamex1 (rtos sk_num1)))) (princ) ) ;做块函数 (defun sk_makeblock1();制作块函数部分 (if (= (tblobjname "block" blockname1) nil) (progn (command "-block" blockname1 pt1 ssblock1 "") (command "-insert" blockname1 pt1 "" "" "") (princ (strcat "\n!!!成功制作新块< " blockname1" >!!!!")) ) ) (princ) ) ;重置块名设置 (defun c:rsb();重置块主函数 (setq sk_num1 nil     sk_blocknamex1 nil) (sk_bname1) (princ "\n 设置成功,请重新运行程序") (princ) ) (PRINC "\n SB 启动程序")

liangzp

支持！！！！！！！！！！！！！

434939575

有注释。别人好消化。谢谢！

xyp1964

664571221

E大提示有多余的括号