求大师帮忙优化代码

18503201445

网上找的代码，自己改的现功能已满足要求，求大师帮忙优化精减代码

2. ;;; 框选封闭区域面积到excel    by:langjs
   
3. ;;; ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
   
4. (defun c:mj (/ d ent f i lst m2 obj pt ss txt x y TextHeight hjmj)
   
5.   (vl-load-com)
   
6. (setq TextHeight (getdist "\n输入标注文字高度:[当前高度:150]"))
   
7. (if (= TextHeight nil) (setq TextHeight 150))
   
8.   (defun maketext (txt pt)             ; 生成文字子函数
   
9. (command "layer" "M" "面积" "C" "6" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
   
10.     (entmake (list '(0 . "TEXT") (cons 62 1) (cons 10 pt) (cons 40 TextHeight) (cons 1 txt) '(41 . 0.8)))
    
11.   )
    
12.   (setvar "cmdecho" 0)
    
13.   (vl-load-com)
    
14.   (setq ss (ssget) ent (entlast))
    
15. (setq num(sslength ss))
    
16.   (command ".region" ss "")
    
17.   (setq ss (ssadd)  lst nil)
    
18.   (while (setq ent (entnext ent))
    
19.     (if (= (cdr (assoc 0 (entget ent))) "REGION")
    
20.       (setq obj (vlax-ename->vla-object ent) pt (vlax-safearray->list (vlax-variant-value (vla-get-centroid obj)))
    
21.             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)
    
22.       )
    
23.     )
    
24.   )
    
25.   (command ".undo" "")
    
26.   (setq lst (vl-sort lst (function (lambda (x y)(< (car (car x)) (car (car y)))))))
    
27.   (setq lst (vl-sort lst (function (lambda (x y)(> (cadr (car x)) (cadr (car y)))))))
    
28. 
    
29. (initget "Y N y n")
    
30. (setq s (getkword "是否导出到excel？ [是(Y)/否(N)]"))
    
31. (if (= s  "Y") (progn
    
32. (setq f (getfiled "指定输出文件路径" "" "xls" 1) f (open f "w"))
    
33.   (write-line "编号\面积(m2)\t周长(m)" f)
    
34. 
    
35.   (setq i 1)
    
36.   (foreach x lst
    
37.     (setq pt (car x) m2 (cadr x) d (caddr x))
    
38.     (maketext (strcat "A" (itoa i)) (list (car pt) (+ (cadr pt) (* 1.2 TextHeight))))
    
39.     (maketext (strcat "S=" m2 "m2") pt)
    
40.     (maketext (strcat "L=" d "m") (list (car pt) (- (cadr pt) (* 1.2 TextHeight))))
    
41.     (write-line (strcat (strcat "A" (itoa i)) "\t" m2 "\t" d) f)
    
42.     (setq i (1+ i))
    
43.   )
    
44. 
    
45. (close f)
    
46. )  (progn
    
47. 
    
48. 
    
49. (setq  table
    
50.    (vla-AddTable
    
51.      (vla-get-ModelSpace
    
52.        (vla-get-ActiveDocument (vlax-get-acad-object))
    
53.      )
    
54.      (vlax-3d-point (setq basept (getpoint "\n插入基点:"))) ;_ 插入点
    
55.      (setq NumRows (+ 3 num))
    
56.      (setq NumColumns 3)
    
57.      (setq RowHeight TextHeight)
    
58.      (setq ColWidth (* 3 TextHeight))
    
59.    )
    
60.   )
    
61. ;;关闭表格的实时更新，以提高修改表格的运行速度
    
62.   (vla-put-HeaderSuppressed table :vlax-true)
    
63.   (vla-put-TitleSuppressed  table :vlax-true)
    
64.   (vla-put-regeneratetablesuppressed  table :vlax-true)
    
65.   ;;写表头内容
    
66.   (vla-settextheight table acTitleRow (* RowHeight 0.7)) ;;设置标题区字高
    
67.   (vla-settextheight table acHeaderRow (* RowHeight 0.7)) ;;设置表头区字高
    
68.   (vla-settextheight table acDataRow (* RowHeight 0.5)) ;;设置数据区字高
    
69.   (vla-setalignment table acDataRow acMiddleCenter) ;;设置单元格居中
    
70.   (vla-settext table 0 0 "汇总表")
    
71. (vla-settext table 1 0 "编号")
    
72. (vla-settext table 1 1 "面积(m2)")
    
73. (vla-settext table 1 2 "周长(m)")
    
74. 
    
75. 
    
76. 
    
77. (setq i 1 hjmj 0 hjzc 0)
    
78. 
    
79.   (foreach x lst
    
80.     (setq pt (car x) m2 (cadr x) d (caddr x))
    
81.     (maketext (strcat "A" (itoa i)) (list (car pt) (+ (cadr pt) (* 1.2 TextHeight))))
    
82.     (maketext (strcat "S=" m2 "m2") pt)
    
83.     (maketext (strcat "L=" d "m") (list (car pt) (- (cadr pt) (* 1.2 TextHeight))))
    
84. 
    
85.     (vla-settext table (+ 1 i) 0 (strcat "A" (itoa i)))
    
86.     (vla-settext table (+ 1 i) 1 m2)
    
87.     (vla-settext table (+ 1 i) 2 d)
    
88. 
    
89.   (setq hjmj (+ hjmj (atof m2)))
    
90. (setq hjzc (+ hjzc (atof d)))
    
91. 
    
92.            
    
93. 
    
94. 
    
95.   (setq i (1+ i))
    
96. 
    
97.   )
    
98.   
    
99.     (vla-settext table (+ 1 i) 0 "合计")
    
100. (vla-settext table (+ 1 i) 1 (rtos hjmj 2 2))
     
101. (vla-settext table (+ 1 i) 2 (rtos hjzc 2 2))
     
102. 
     
103. 
     
104. ;;打开表格更新
     
105.   (vla-put-HeaderSuppressed table :vlax-false)
     
106.   (vla-put-TitleSuppressed  table :vlax-false)
     
107.   (vla-put-regeneratetablesuppressed  table :vlax-false)
     
108. ))
     
109.   
     
110.   (princ)
     
111. )

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

sicky111

能用就行了