五边形lisp程序_提料程序-源码分享 - AutoLISP/Visual LISP 编程技术 - CAD论坛 - 明经CAD社区 - Powered by Discuz!...

[code="lisp]

(defun c:chc (/ os ss s1 cds pt1 pt2 pt3 pt4 ptx1 ptx2 ptx3 ptx4 ptx5 ptx6 ptx7 ptx8 ptx9 ptx10 ptx11 ptx12 ptx13 ptx15 ptx16 py1 py2 py3 py4 py5 py6 th thlist en vlen wz pty1 pty2 en2 kuandu gaodu mianji mianjihe en1x boen xuhao interszj cd)

(setvar "cmdecho" 0)

(setq os (getvar "osmode"))

(setvar "osmode" 0)

;设置完毕，开始绘制表格

(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 (* pi 1.5) hh))

(setq pt3 (polar pt2 0 1400))

(command "pline" pt1 pt2 pt3 pt4 "")

(command "line" pt1 pt4 "")

(setq en1 (entlast))

(command "array" en1 "" "r" (+ sl 4) 1 -100)

;以下绘制表头

(command "._undo" "begin")

(setq inters1 (list (+ 700 (car pt1)) (- (cadr pt1) 50)))

(command "text" "m" inters1 55 0 "石材尺寸清单")

(setq inters2 (list (+ 200 (car pt1)) (- (cadr pt1) 150)))

(command "text" "m" inters2 40 0 "石材种类")

(setq pty1 (list (+ 400 (car pt1)) (- (cadr pt1) 200)))

(setq pty2 (list (+ 400 (car pt1)) (- (cadr pt1) 100)))

(command "line" pty1 pty2 "")

(setq inters3 (polar inters2 0 800))

(command "text" "m" inters3 40 0 "厚度")

(setq ptx3 (polar pty1 0 500))

(setq ptx4 (polar pty2 0 500))

(setq pty3 (polar ptx3 0 250))

(setq pty4 (polar ptx4 0 250))

(command "line" ptx3 ptx4 "" "line" pty3 pty4 "")

(setq ptx5 (polar pt1 (* pi 1.5) 250))

(setq ptx6 (polar ptx5 0 60))

(command "text" "m" ptx6 40 0 "序号")

(setq ptx7 (polar ptx6 0 200))

(command "text" "m" ptx7 40 0 "产品编号")

(setq ptx8 (polar ptx7 0 250))

(command "text" "m" ptx8 40 0 "宽度")

(setq ptx9 (polar ptx8 0 250))

(command "text" "m" ptx9 40 0 "高度")

(setq ptx10 (polar ptx9 0 250))

(command "text" "m" ptx10 40 0 "面积")

(setq ptx11 (polar ptx10 0 250))

(command "text" "m" ptx11 40 0 "备注")

;以下绘制表尾

(setq interszj (list (+ 450 (car pt2)) (+ 50 (cadr pt2))))

(command "text" "m" interszj 45 0 "总计")

(setq ptx12 (polar pt2 0 900))

(setq ptx13 (polar ptx12 (* pi 0.5) 100))

(command "line" ptx12 ptx13 "")

(setq ptx15 (polar ptx12 0 250))

(setq ptx16 (polar ptx15 (* pi 0.5) 100))

(command "line" ptx15 ptx16 "")

;绘制竖线

(setq py1 (list (+ 120 (car pt1)) (- (cadr pt1) 200)))

(setq py2 (list (+ 120 (car pt2)) (+ 100 (cadr pt2))))

(command "line" py1 py2 "")

(setq en2 (entlast))

(setq py3 (polar py1 0 280) py4 (polar py3 0 250) py5 (polar py4 0 250) py6 (polar py5 0 250))

(command "copy" en2 "" "m" py1 py3 py4 py5 py6 "")

;绘制表头表尾结束**************

(setq thlist (ssget-cons ss))

(setq th 0 xuhao 1 jiange 100 mianjihe 0)

(repeat (length thlist)

(setq en (nth th thlist))

(setq vlen (Vlax-Ename->Vla-Object en))

(setq wz (vla-get-TextString vlen))

(setq cd (cdr (assoc 10 (entget en))))

(setq cds (cdr (assoc 11 (entget en))))

(setvar "cecolor" "6")

(setq en1x (entlast))

(command "boundary" cd "")

(setq boen (entlast))

(if (/= (equal boen en1x) nil)

(progn (command "boundary" cds "")

(setq boen (entlast))

)

)

(if (= (equal boen en1x) nil)

(progn

(Min_Max)

(setq gaodu (- maxy0 miny0) kuandu (- maxx0 minx0))

(command "erase" boen "")

(setq mianji (/ (* kuandu gaodu) 1000000))

(setq mianjihe (+ mianjihe mianji))

(setq kuandu (rtos kuandu 2 0) gaodu (rtos gaodu 2 0) mianji (rtos mianji 2 2))

(command "text" "m" (list (car ptx8) (- (cadr ptx8) jiange)) 35 0 kuandu)

(command "text" "m" (list (car ptx9) (- (cadr ptx9) jiange)) 35 0 gaodu)

(command "text" "m" (list (car ptx10) (- (cadr ptx10) jiange)) 35 0 mianji)

)

)

(command "text" "m" (list (car ptx6) (- (cadr ptx6) jiange)) 35 0 (rtos xuhao 2 0))

(command "text" "m" (list (car ptx7) (- (cadr ptx7) jiange)) 35 0 wz)

(setq jiange (+ jiange 100))

(setq xuhao (1+ xuhao))

(setq th (1+ th))

)

(setq mianjihe (rtos mianjihe 2 2))

(command "text" "m" (list (- (car pt3) 375) (+ 50 (cadr pt3))) 35 0 mianjihe)

(setq ssbg (ssget "w" pt1 pt3))

;*****程序完成，恢复各项设置

(setvar "osmode" os)

(setvar "cecolor" "1")

(command "scale" ssbg "" pt1 "r" pt1 pt3 pause)

(command "._undo" "end")

(princ "\n操作完成!!")

(prin1)

)

(prompt "*****************提取石材料单尺寸程序，命令CHC****程序对图纸要求很高，只做交流，不对一切因使用本程序造成的后果负责***")

(prin1)

;******选择集转换为列表并从小到大排列的子程序****

(defun ssget-cons (ss / k en1 thlist)

(setq thlist ())

(setq k 0)

(repeat (sslength ss)

(setq en1 (ssname ss k))

(setq thlist (cons en1 thlist))

(setq k (1+ k))

)

(setq thlist (vl-sort thlist (function (lambda (x1 x2) (< (atoi (texts X1)) (atoi (texts X2)))))))

)

;提取出字符串中的数字

(defun texts (en / )

(setq regex (vlax-create-object "Vbscript.RegExp"))

(vlax-put-property regex "IgnoreCase" 1)

(vlax-put-property regex "Global" 1)

(setq en1 (vlax-ename->vla-object en))

(setq enz (vla-get-TextString en1))

(vlax-put-property regex "Pattern" "[^0-9]")

(setq en1 (vlax-invoke-method  regex "Replace" enz ""))

)

;;;子程序，求选集是大外形坐标

(defun Min_Max()

(setq minx0 10e6 miny0 10e6 maxx0 -10e6 maxy0 -10e6)

(vla-getboundingbox(vlax-ename->vla-object boen) 'minp 'maxp)

(setq minp (vlax-safearray->list minp)

maxp (vlax-safearray->list maxp))

(setq minx (car minp)

maxx (car maxp)

miny (cadr minp)

maxy (cadr maxp))

(if (> minx0 minx) (setq minx0 minx))

(if (> miny0 miny) (setq miny0 miny))

(if (< maxx0 maxx) (setq maxx0 maxx))

(if (< maxy0 maxy) (setq maxy0 maxy))

)

(prin1)

[/code]

这个是很多年前写的、、、

水平很菜

有需要的朋友可以拿去随便改随便用

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有帐号？注册

x