提料程序---源码分享

tanjurun

有思路很重要，

p-3-ianlcc

fan_zh 发表于 2019-7-24 13:48
我这个，可能更好用些，带合并数量并编号功能

您这个感觉很好用～
方便分享吗？

fan_zh

p-3-ianlcc 发表于 2020-6-1 15:58
您这个感觉很好用～
方便分享吗？

有需要可以定制，pm我吧

fan_zh

p-3-ianlcc 发表于 2020-6-1 15:58
您这个感觉很好用～
方便分享吗？

有需要可以定制，pm我吧

尘缘一生

程序面积计算不准确，另外，用了很多的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)
  

tdl555

十分不错