求大师帮忙优化代码
网上找的代码，自己改的现功能已满足要求，求大师帮忙优化精减代码;;; 框选封闭区域面积到excel by:langjs;;; ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
(defun c:mj (/ d ent f i lst m2 obj pt ss txt x y TextHeight hjmj)
(vl-load-com)
(setq TextHeight (getdist "\n输入标注文字高度:[当前高度:150]"))
(if (= TextHeight nil) (setq TextHeight 150))
(defun maketext (txt pt) ; 生成文字子函数
(command "layer" "M" "面积" "C" "6" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
(entmake (list '(0 . "TEXT") (cons 62 1) (cons 10 pt) (cons 40 TextHeight) (cons 1 txt) '(41 . 0.8)))
)
(setvar "cmdecho" 0)
(vl-load-com)
(setq ss (ssget) ent (entlast))
(setq num(sslength ss))
(command ".region" ss "")
(setq ss (ssadd)lst nil)
(while (setq ent (entnext ent))
(if (= (cdr (assoc 0 (entget ent))) "REGION")
(setq obj (vlax-ename->vla-object ent) pt (vlax-safearray->list (vlax-variant-value (vla-get-centroid obj)))
m2 (rtos (/(vla-get-area obj) 1000000) 2 2) d (rtos(/ (vla-get-perimeter obj) 1000) 2 2) lst (cons (list pt m2 d) lst)
)
)
)
(command ".undo" "")
(setq lst (vl-sort lst (function (lambda (x y)(< (car (car x)) (car (car y)))))))
(setq lst (vl-sort lst (function (lambda (x y)(> (cadr (car x)) (cadr (car y)))))))
(initget "Y N y n")
(setq s (getkword "是否导出到excel？ [是(Y)/否(N)]"))
(if (= s"Y") (progn
(setq f (getfiled "指定输出文件路径" "" "xls" 1) f (open f "w"))
(write-line "编号\面积(m2)\t周长(m)" f)
(setq i 1)
(foreach x lst
(setq pt (car x) m2 (cadr x) d (caddr x))
(maketext (strcat "A" (itoa i)) (list (car pt) (+ (cadr pt) (* 1.2 TextHeight))))
(maketext (strcat "S=" m2 "m2") pt)
(maketext (strcat "L=" d "m") (list (car pt) (- (cadr pt) (* 1.2 TextHeight))))
(write-line (strcat (strcat "A" (itoa i)) "\t" m2 "\t" d) f)
(setq i (1+ i))
)
(close f)
)(progn
(setqtable
(vla-AddTable
(vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(vlax-3d-point (setq basept (getpoint "\n插入基点:"))) ;_ 插入点
(setq NumRows (+ 3 num))
(setq NumColumns 3)
(setq RowHeight TextHeight)
(setq ColWidth (* 3 TextHeight))
)
)
;;关闭表格的实时更新，以提高修改表格的运行速度
(vla-put-HeaderSuppressed table :vlax-true)
(vla-put-TitleSuppressedtable :vlax-true)
(vla-put-regeneratetablesuppressedtable :vlax-true)
;;写表头内容
(vla-settextheight table acTitleRow (* RowHeight 0.7)) ;;设置标题区字高
(vla-settextheight table acHeaderRow (* RowHeight 0.7)) ;;设置表头区字高
(vla-settextheight table acDataRow (* RowHeight 0.5)) ;;设置数据区字高
(vla-setalignment table acDataRow acMiddleCenter) ;;设置单元格居中
(vla-settext table 0 0 "汇总表")
(vla-settext table 1 0 "编号")
(vla-settext table 1 1 "面积(m2)")
(vla-settext table 1 2 "周长(m)")
(setq i 1 hjmj 0 hjzc 0)
(foreach x lst
(setq pt (car x) m2 (cadr x) d (caddr x))
(maketext (strcat "A" (itoa i)) (list (car pt) (+ (cadr pt) (* 1.2 TextHeight))))
(maketext (strcat "S=" m2 "m2") pt)
(maketext (strcat "L=" d "m") (list (car pt) (- (cadr pt) (* 1.2 TextHeight))))
(vla-settext table (+ 1 i) 0 (strcat "A" (itoa i)))
(vla-settext table (+ 1 i) 1 m2)
(vla-settext table (+ 1 i) 2 d)
(setq hjmj (+ hjmj (atof m2)))
(setq hjzc (+ hjzc (atof d)))
(setq i (1+ i))
)
(vla-settext table (+ 1 i) 0 "合计")
(vla-settext table (+ 1 i) 1 (rtos hjmj 2 2))
(vla-settext table (+ 1 i) 2 (rtos hjzc 2 2))
;;打开表格更新
(vla-put-HeaderSuppressed table :vlax-false)
(vla-put-TitleSuppressedtable :vlax-false)
(vla-put-regeneratetablesuppressedtable :vlax-false)
))
(princ)
) 能用就行了
页:
[1]