以下源码为批量统计面积及长度输出到Excel，请大家修改仅批量统计面积输出到Excel....

注册

(defun c:zcmj (/ d ent f i lst m2 obj pt ss txt x y)
(setq TextHeight (getdist "\n输入标注文字高度:")
Textbh (getstring "\n输入编号前缀:"))
  (defun maketext (txt pt)             ; 生成文字子函数
    (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))
  (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)))))))
  (setq f (getfiled "指定输出文件路径" "" "xls" 1) f (open f "a"))
  (write-line "编号\t周长(m)\t面积(m2)" f)
  (setq i 1)
  (foreach x lst
    (setq pt (car x) m2 (cadr x) d (caddr x))
    (maketext (strcat Textbh (itoa i)) (list (car pt) (+ (cadr pt) (* 1.2 TextHeight))))
    (maketext (strcat "L=" d "m") pt)
    (maketext (strcat "S=" m2 "m2") (list (car pt) (- (cadr pt) (* 1.2 TextHeight))))
    (write-line (strcat (strcat Textbh (itoa i)) "\t" d "\t" m2) f)
    (setq i (1+ i))
  )
  (close f)
  (princ)
)

434939575

2. [code=lisp](defun c:tt (/ d ent f i lst m2 obj pt ss txt x y)
   
3.   (setq        TextHeight (getdist "\n输入标注文字高度:")
   
4.         Textbh           (getstring "\n输入编号前缀:")
   
5.   )
   
6.   (defun maketext (txt pt)                ; 生成文字子函数
   
7.     (entmake (list '(0 . "TEXT")
   
8.                    (cons 62 1)
   
9.                    (cons 10 pt)
   
10.                    (cons 40 TextHeight)
    
11.                    (cons 1 txt)
    
12.                    '(41 . 0.8)
    
13.              )
    
14.     )
    
15.   )
    
16.   (setvar "cmdecho" 0)
    
17.   (vl-load-com)
    
18.   (setq        ss  (ssget)
    
19.         ent (entlast)
    
20.   )
    
21.   (command ".region" ss "")
    
22.   (setq        ss  (ssadd)
    
23.         lst nil
    
24.   )
    
25.   (while (setq ent (entnext ent))
    
26.     (if        (= (cdr (assoc 0 (entget ent))) "REGION")
    
27.       (setq obj        (vlax-ename->vla-object ent)
    
28.             pt        (vlax-safearray->list
    
29.                   (vlax-variant-value (vla-get-centroid obj))
    
30.                 )
    
31.             m2        (rtos (/ (vla-get-area obj) 1000000) 2 2)
    
32.           ;  d        (rtos (/ (vla-get-perimeter obj) 1000) 2 2)
    
33.             lst        (cons (list pt m2 ;d
    
34.                             ) lst)
    
35.       )
    
36.     )
    
37.   )
    
38.   (command ".undo" "")
    
39.   (setq
    
40.     lst        (vl-sort
    
41.           lst
    
42.           (function (lambda (x y) (< (car (car x)) (car (car y)))))
    
43.         )
    
44.   )
    
45.   (setq
    
46.     lst        (vl-sort
    
47.           lst
    
48.           (function (lambda (x y) (> (cadr (car x)) (cadr (car y)))))
    
49.         )
    
50.   )
    
51.   (setq        f (getfiled "指定输出文件路径" "" "xls" 1)
    
52.         f (open f "a")
    
53.   )
    
54.   ;(write-line "编号\t周长(m)\t面积(m2)" f)
    
55.   (write-line "编号\t面积(m2)" f)
    
56.   (setq i 1)
    
57.   (foreach x lst
    
58.     (setq pt (car x)
    
59.           m2 (cadr x)
    
60.           d  (caddr x)
    
61.     )
    
62.     (maketext (strcat Textbh (itoa i))
    
63.               (list (car pt) (+ (cadr pt) (* 1.2 TextHeight)))
    
64.     )
    
65.    ; (maketext (strcat "L=" d "m") pt)
    
66.     (maketext (strcat "S=" m2 "m2")
    
67.               (list (car pt) (- (cadr pt) (* 1.2 TextHeight)))
    
68.     )
    
69.     (write-line
    
70.       ;(strcat (strcat Textbh (itoa i)) "\t" d "\t" m2)
    
71.       (strcat (strcat Textbh (itoa i))  "\t" m2)
    
72.       f
    
73.     )
    
74.     (setq i (1+ i))
    
75.   )
    
76.   (close f)
    
77.   (princ)
    
78. )

[code=lisp](defun c:tt (/ d ent f i lst m2 obj pt ss txt x y)<br />   (setq        TextHeight (getdist "\n输入标注文字高度:")<br />         Textbh           (getstring "\n输入编号前缀:")<br />   )<br />   (defun maketext (txt pt)                ; 生成文字子函数<br />     (entmake (list '(0 . "TEXT")<br />                    (cons 62 1)<br />                    (cons 10 pt)<br />                    (cons 40 TextHeight)<br />                    (cons 1 txt)<br />                    '(41 . 0.8)<br />              )<br />     )<br />   )<br />   (setvar "cmdecho" 0)<br />   (vl-load-com)<br />   (setq        ss  (ssget)<br />         ent (entlast)<br />   )<br />   (command ".region" ss "")<br />   (setq        ss  (ssadd)<br />         lst nil<br />   )<br />   (while (setq ent (entnext ent))<br />     (if        (= (cdr (assoc 0 (entget ent))) "REGION")<br />       (setq obj        (vlax-ename->vla-object ent)<br />             pt        (vlax-safearray->list<br />                   (vlax-variant-value (vla-get-centroid obj))<br />                 )<br />             m2        (rtos (/ (vla-get-area obj) 1000000) 2 2)<br />           ;  d        (rtos (/ (vla-get-perimeter obj) 1000) 2 2)<br />             lst        (cons (list pt m2 ;d<br />                             ) lst)<br />       )<br />     )<br />   )<br />   (command ".undo" "")<br />   (setq<br />     lst        (vl-sort<br />           lst<br />           (function (lambda (x y) (< (car (car x)) (car (car y)))))<br />         )<br />   )<br />   (setq<br />     lst        (vl-sort<br />           lst<br />           (function (lambda (x y) (> (cadr (car x)) (cadr (car y)))))<br />         )<br />   )<br />   (setq        f (getfiled "指定输出文件路径" "" "xls" 1)<br />         f (open f "a")<br />   )<br />   ;(write-line "编号\t周长(m)\t面积(m2)" f)<br />   (write-line "编号\t面积(m2)" f)<br />   (setq i 1)<br />   (foreach x lst<br />     (setq pt (car x)<br />           m2 (cadr x)<br />           d  (caddr x)<br />     )<br />     (maketext (strcat Textbh (itoa i))<br />               (list (car pt) (+ (cadr pt) (* 1.2 TextHeight)))<br />     )<br />    ; (maketext (strcat "L=" d "m") pt)<br />     (maketext (strcat "S=" m2 "m2")<br />               (list (car pt) (- (cadr pt) (* 1.2 TextHeight)))<br />     )<br />     (write-line<br />       ;(strcat (strcat Textbh (itoa i)) "\t" d "\t" m2)<br />       (strcat (strcat Textbh (itoa i))  "\t" m2)<br />       f<br />     )<br />     (setq i (1+ i))<br />   )<br />   (close f)<br />   (princ)<br /> )

[/code]

lifuq1979

m2        (rtos (/ (vla-get-area obj) 1000000) 2 2)即然单位是平方米为什么要/1000000
个人认为
m2        (rtos (vla-get-area obj) 2 2)

注册

上面源码为批量统计面积及长度输出到Excel，请大咖修改仅批量统计面积输出到Excel，长度无需统计及输出，谢谢

注册

434939575 发表于 2019-9-15 09:00
[/code]

可以了，多谢多谢

fxlt619

有把标注文字（不炸开）提取到cad或excel里，合并排序的吗

mpk023

为什么我用了后显示面积为000呢~~~~

664571221

434939575 发表于 2019-9-15 09:00
[/code]

你好能否修改为批量统计长度输出到excel

434939575

664571221 发表于 2019-10-22 12:19
你好能否修改为批量统计长度输出到excel

我对Excel这个不了解。没弄过。

liuties

学习学习   感谢楼主分享