我这个，可能更好用些，带合并数量并编号功能
您这个感觉很好用～
方便分享吗？ p-3-ianlcc 发表于 2020-6-1 15:58
您这个感觉很好用～
方便分享吗？
有需要可以定制，pm我吧 p-3-ianlcc 发表于 2020-6-1 15:58
您这个感觉很好用～
方便分享吗？
有需要可以定制，pm我吧 本帖最后由 尘缘一生 于 2021-12-2 19:38 编辑
程序面积计算不准确，另外，用了很多的COMMAND，速度慢，再者，对选择集排序方面，也是有点问题，那就是，对于文字选择集的，失效，再者，对于画完了表，再SCALE的方式，值得探讨，最好适合比例一次画成即可，本次没修改这部分。
我改写一下，看模样吧
[*];; 提料程序---源码分享
[*](defun c:chc (/ e_lst ss s1 pt1 pt2 pt3 pt4 ptx1 ptx2 ptx3 ptx4 ptx5 ptx6 ptx7 ptx8 ptx9 ptx10 ptx11 ptx12 ptx13 ptx15 ptx16 py1 py2 th thlist en wz pty1 pty2
[*] kuandu gaodu mianji mianjihe boen xuhao interszj e plis hh sl obj w h)
[*](setq e_lst (sysvar '("osmode" "cmdecho" "ORTHOMODE")))
[*](setvar "cmdecho" 0)
[*](setvar "OSMODE" 0)
[*](setvar "ORTHOMODE" 0)
[*](command "._undo" "begin")
[*];设置完毕，开始绘制表格
[*](setq ss (ssget '((0 . "*TEXT"))))
[*](setq sl (sslength ss))
[*](setq pt1 (getpoint "\n 指定表格角点"))
[*](setq pt4 (polar pt1 0 1400))
[*](setq hh (+ (* sl 100) 400))
[*](setq pt2 (polar pt1 3pi2 hh))
[*](setq pt3 (polar pt2 0 1400))
[*](setq e (entlast))
[*](makelwpolyline (list pt1 pt2 pt3 pt4) 0 t)
[*](makeline pt1 pt4)
[*](command "array" (entlast) "" "r" (+ sl 4) 1 -100)
[*];以下绘制表头
[*](setq inters1 (list (+ 700 (car pt1)) (- (cadr pt1) 50) 0))
[*](slmkwz "出版尺寸" inters1 (/ 55 slbl) 0 nil "表格" nil nil "m")
[*](setq inters2 (list (+ 200 (car pt1)) (- (cadr pt1) 150) 0))
[*](slmkwz "板材编号" inters2 (/ 40 slbl) 0 nil "表格" nil nil "m")
[*](setq pty1 (list (+ 400 (car pt1)) (- (cadr pt1) 200)))
[*](setq pty2 (list (+ 400 (car pt1)) (- (cadr pt1) 100)))
[*](makeline pty1 pty2)
[*](setq inters3 (polar inters2 0 800))
[*](slmkwz "厚度" inters3 (/ 40 slbl) 0 nil "表格" nil nil "m")
[*](setq ptx3 (polar pty1 0 500))
[*](setq ptx4 (polar pty2 0 500))
[*](setq pty3 (polar ptx3 0 250))
[*](setq pty4 (polar ptx4 0 250))
[*](makeline ptx3 ptx4)
[*](makeline pty3 pty4)
[*](setq ptx5 (polar pt1 3pi2 250))
[*](setq ptx6 (polar ptx5 0 60))
[*](slmkwz "序号" ptx6 (/ 40 slbl) 0 nil "表格" nil nil "m")
[*](setq ptx7 (polar ptx6 0 200))
[*](slmkwz "产品编号" ptx7 (/ 40 slbl) 0 nil "表格" nil nil "m")
[*](setq ptx8 (polar ptx7 0 250))
[*](slmkwz "宽度" ptx8 (/ 40 slbl) 0 nil "表格" nil nil "m")
[*](setq ptx9 (polar ptx8 0 250))
[*](slmkwz "高度" ptx9 (/ 40 slbl) 0 nil "表格" nil nil "m")
[*](setq ptx10 (polar ptx9 0 250))
[*](slmkwz "面积m2" ptx10 (/ 40 slbl) 0 nil "表格" nil nil "m")
[*](setq ptx11 (polar ptx10 0 250))
[*](slmkwz "备注" ptx11 (/ 40 slbl) 0 nil "表格" nil nil "m")
[*];以下绘制表尾
[*](setq interszj (list (+ 450 (car pt2)) (+ 50 (cadr pt2)) 0))
[*](slmkwz "总计" interszj (/ 45 slbl) 0 nil "表格" nil nil "m")
[*](setq ptx12 (polar pt2 0 900))
[*](setq ptx13 (polar ptx12 pi2 100))
[*](makeline ptx12 ptx13)
[*](setq ptx15 (polar ptx12 0 250))
[*](setq ptx16 (polar ptx15 pi2 100))
[*](makeline ptx15 ptx16)
[*];绘制竖线
[*](setq py1 (list (+ 120 (car pt1)) (- (cadr pt1) 200)))
[*](setq py2 (list (+ 120 (car pt2)) (+ 100 (cadr pt2))))
[*](makeline py1 py2)
[*](setq py1 (polar py1 0 280))
[*](setq py2 (polar py2 0 280))
[*](makeline py1 py2)
[*](setq py1 (polar py1 0 250))
[*](setq py2 (polar py2 0 250))
[*](makeline py1 py2)
[*](setq py1 (polar py1 0 250))
[*](setq py2 (polar py2 0 250))
[*](makeline py1 py2)
[*](setq py1 (polar py1 0 250))
[*](setq py2 (polar py2 0 250))
[*](makeline py1 py2)
[*];绘制表结束
[*]
[*](setq thlist (ss-enlst ss)) ;;选择集转实体名表并排序
[*](setq xuhao 1 jiange 100 mianjihe 0)
[*](repeat (setq th (length thlist))
[*] (setq en (nth (setq th (1- th)) thlist))
[*] (setq wz (getstr en))
[*] (command "boundary" "a" "o" "p" "" (e-mid en) "");生成多段线
[*] (setq boen (entlast))
[*] (if boen
[*] (progn
[*] (setq plis (e-box4 boen t) obj (en2obj boen))
[*] (setq w (* (distance (car plis) (cadddr plis)) (getvar "dimlfac")))
[*] (setq h (* (distance (car plis) (cadr plis)) (getvar "dimlfac")))
[*] (if (>= w h)
[*] (progn
[*] (setq kuandu h)
[*] (setq gaodu w)
[*] )
[*] (progn
[*] (setq kuandu w)
[*] (setq gaodu h)
[*] )
[*] )
[*] (if (vlax-property-available-p obj "area")
[*] (setq mianji (* (getvar "dimlfac") (getvar "dimlfac") (vlax-get-property obj 'area) 0.000001))
[*] )
[*] (entdel boen)
[*] )
[*] (setq mianji 0.0 kuandu 0.0 gaodu 0.0)
[*] )
[*] (setq mianjihe (+ mianjihe mianji))
[*] (setq mianji (rtos mianji 2 2) kuandu (rtos kuandu 2 0) gaodu (rtos gaodu 2 0))
[*] (slmkwz kuandu (list (car ptx8) (- (cadr ptx8) jiange) 0) (/ 35 slbl) 0 nil "表格" nil nil "m")
[*] (slmkwz gaodu (list (car ptx9) (- (cadr ptx9) jiange) 0) (/ 35 slbl) 0 nil "表格" nil nil "m")
[*] (slmkwz mianji (list (car ptx10) (- (cadr ptx10) jiange) 0) (/ 35 slbl) 0 nil "表格" nil nil "m")
[*] (slmkwz (rtos xuhao 2 0) (list (car ptx6) (- (cadr ptx6) jiange) 0) (/ 35 slbl) 0 nil "表格" nil nil "m")
[*] (slmkwz wz (list (car ptx7) (- (cadr ptx7) jiange) 0) (/ 35 slbl) 0 nil "表格" nil nil "m") ;;编号
[*] (setq jiange (+ jiange 100))
[*] (setq xuhao (1+ xuhao))
[*])
[*](slmkwz (rtos mianjihe 2 2) (list (- (car pt3) 375) (+ 50 (cadr pt3)) 0) (/ 35 slbl) 0 nil "表格" nil nil "m")
[*];*****程序完成，恢复各项设置
[*](command "scale" (last_ent e) "" pt1 "r" pt1 pt3 pause)
[*](command "._undo" "end")
[*](mapcar 'eval e_lst)
[*])
[*](prompt "提取石材料单尺寸程序，命令CHC****程序对图纸要求很高，只做交流，不对一切因使用本程序造成的后果负责***")
[*](prin1)
十分不错
页:
1
[2]