求改进代码

上善若水001

以下代码为网上寻得，麻烦大侠们帮忙改进下，谢谢！
要求：将选择后的表中重复项保留一项，并在面积后添加一项“数量”
(defun c:qq (/ appxls col ent ent1 f i lst m2 newbook newitem newsheet numrow pt ss txt value xlscells xlsworkbooks)
  (defun initexcel ()
    (setq appxls (vlax-get-or-create-object "excel.application")
          xlsworkbooks (vlax-get-property appxls "workbooks")
          newbook (vlax-invoke-method xlsworkbooks "add")
          newsheet (vlax-get-property newbook "sheets")
          newitem (vlax-get-property newsheet "item" 1)
          xlscells (vlax-get-property newitem "cells")
    )
    (vla-put-visible appxls :vlax-true)
  )
  (defun endexcel ()
    (vlax-release-object xlscells)
    (vlax-release-object newitem)
    (vlax-release-object newsheet)
    (vlax-release-object newbook)
    (vlax-release-object xlsworkbooks)
    (vlax-release-object appxls)
  )
  (defun datacell (nurow col value)
    (vlax-put-property xlscells "item" numrow col (vl-princ-to-string value))
  )
  (setvar "cmdecho" 0)
  (vl-load-com)
  (if (setq ss (ssget '((0 . "*TEXT"))))
    (progn
      (= lst nil)
      (repeat (setq i (sslength ss))
        (setq ent (entget (ssname ss (setq i (1- i))))
              pt (cdr (assoc 10 ent))
              txt (cdr (assoc 1 ent))
        )
        (command "-boundary" pt "")
        (command ".region" (entlast) "")
        (setq ent1 (entlast))
        (if (= (cdr (assoc 0 (entget ent1))) "REGION")
          (setq ent (vlax-ename->vla-object ent1)
                m2 (rtos (vla-get-area ent))
                lst (cons (list txt m2) lst)
                f (entdel ent1)
          )
        )
      )
      (setq lst (vl-sort lst (function (lambda (x y)
                                           (< (car x) (car y))
                                         )
                               )
                 )
      )
      (setq lst (cons (list "版号" "面积") lst))
      (initexcel)
      (setq numrow 1)
      (foreach f lst
        (datacell numrow 1 (car f))
        (datacell numrow 2 (cadr f))
        (setq numrow (1+ numrow))
      )
      (endexcel)
    )
  )
  (princ)
)

st788796

文字处保证能生成闭合线？
是在已有表增加？还是新建表？

上善若水001

st788796 发表于 2013-12-16 10:25
文字处保证能生成闭合线？
是在已有表增加？还是新建表？

{:soso_e117:}论坛里找的，很多看都看不懂所以自己改不了，来求救来了。。。。。。。。。

st788796

上善若水001 发表于 2013-12-16 10:28
论坛里找的，很多看都看不懂所以自己改不了，来求救来了。。。。。。。。。

你得说清楚要做什么才好有针对性修改，另外这个程序能不能运行，运行结果哪里和你的要求有差距，这些要让别人明白了才好帮你

st788796

1. (defun c:tt (/ ss strl)
   
2.   (if (setq ss (ssget '((0 . "*text"))))
   
3.     (progn
   
4.       (setq strl (mapcar '(lambda (x / pt str e a)
   
5.                             (setq pt  (xdrx_getpropertyvalue x "Position")
   
6.                                   str (xdrx_getpropertyvalue x "Textstring")
   
7.                             )
   
8.                             (if        (setq e (xdrx_geom_bpoly pt))
   
9.                               (progn
   
10.                                 (setq a (car (xdrx_getarea e)))
    
11.                                 (xdrx_entity_delete e)
    
12.                                 (list str a)
    
13.                               )
    
14.                             )
    
15.                           )
    
16.                          (xdrx_pickset->ents ss)
    
17.                  )
    
18.             strl (XD::List:GroupByIndex strl 0)
    
19.             strl (mapcar '(lambda (x)
    
20.                             (strcat (car x)
    
21.                                     " "
    
22.                                     (rtos (cadr x) 2 3)
    
23.                                     " "
    
24.                                     (itoa (length (cdr x)))
    
25.                             )
    
26.                           )
    
27.                          strl
    
28.                  )
    
29.             strl (cons "型号 面积 数量" strl)
    
30.       )
    
31.       (XD::List:Tofile "d:\\area.csv" strl);_文件名自己修改
    
32.     )
    
33.   )
    
34.   (princ)
    
35. )

(defun c:tt (/ ss strl)<br />   (if (setq ss (ssget '((0 . "*text"))))<br />     (progn<br />       (setq strl (mapcar '(lambda (x / pt str e a)<br />                             (setq pt  (xdrx_getpropertyvalue x "Position")<br />                                   str (xdrx_getpropertyvalue x "Textstring")<br />                             )<br />                             (if        (setq e (xdrx_geom_bpoly pt))<br />                               (progn<br />                                 (setq a (car (xdrx_getarea e)))<br />                                 (xdrx_entity_delete e)<br />                                 (list str a)<br />                               )<br />                             )<br />                           )<br />                          (xdrx_pickset->ents ss)<br />                  )<br />             strl (XD::List:GroupByIndex strl 0)<br />             strl (mapcar '(lambda (x)<br />                             (strcat (car x)<br />                                     " "<br />                                     (rtos (cadr x) 2 3)<br />                                     " "<br />                                     (itoa (length (cdr x)))<br />                             )<br />                           )<br />                          strl<br />                  )<br />             strl (cons "型号 面积 数量" strl)<br />       )<br />       (XD::List:Tofile "d:\\area.csv" strl);_文件名自己修改<br />     )<br />   )<br />   (princ)<br /> )

上善若水001

st788796 发表于 2013-12-16 17:11

谢谢！！！！！！！