[LISP程序]：统计图元个数（位置相同的多个同种图元只计一个）

tengteb

(DEFUN C:tbCount (/ Main Unique fuzz)
  (defun Main (/ tmp el SS en enType acme1 acme2 ids1 ids2 lst SSet)
    (setq SS   (TBC:GetEnts
                 '((0 . "CIRCLE,INSERT,LINE,LWPOLYLINE,TEXT,MTEXT"))
               )
          SSet (ssadd)
          fuzz 0.01 ;指定位置坐标点的误差
    )
    (foreach el        SS
      (setq en           (entget el)
            enType (TBC:DXF 0 en)
            acme1  nil
            acme2  nil
      )
      (cond ((= enType "CIRCLE")
             (setq ids1        '(0 40)
                   ids2        '(10)
             )
            )
            ((= enType "INSERT")
             (setq ids1        '(0 2 41 42 43 44 45 50 66 70 71)
                   ids2        '(10)
             )
            )
            ((= enType "LINE")
             (setq ids1        '(0)
                   ids2        '(10 11)
             )
            )
            ((= enType "LWPOLYLINE")
             (setq ids1         '(0 43 70 90)
                   ids2         '()
                   acme1 '(40 41 42)
                   acme2 '(10)
             )
            )
            ((= enType "TEXT")
             (setq ids1        '(0 1 7 40 50 51 71 72 73)
                   ids2        '(10 11)
             )
            )
            ((= enType "MTEXT")
             (setq ids1        '(0 1 7 40 41 42 43 44 50 71 72 73)
                   ids2        '(10 11)
             )
            )
      )
      (setq ids1 (TBC:DXFS ids1 en)
            ids1 (append ids1 (mapcar '(lambda (x) (TBC:mDXF x en)) acme1))
            ids2 (TBC:DXFS ids2 en)
            ids2 (append ids2 (mapcar '(lambda (x) (TBC:mDXF x en)) acme2))
            tmp         (list ids1 ids2)
      )
      (if (Unique tmp lst)
        (setq SSet (ssadd el SSet)
              lst  (append lst (list tmp))
        )
      )
    )
    (sssetfirst nil SSet)
    (TBC:Command '("regen") nil)
    (princ)
  )

  (defun Unique (el lst / a b)
    (setq a (car el)
          b (cadr el)
    )
    (if        lst
      (vl-every
        '(lambda (x)
           (not (and (equal a (car x)) (equal b (cadr x) fuzz)))
         )
        lst
      )
      T
    )
  )

  (Main)
)

  ;选择指定过滤条件的实体名表
(defun TBC:GetEnts (filter / i n SSET enName RSET)
  (setq        SSET (ssget filter)
        n    (if SSET
               (sslength SSET)
               0
             )
        i    0
  )
  (while (< i n)
    (setq enName (ssname SSET i)
          RSET         (cons enName RSET)
          i         (1+ i)
    )
  )
  (reverse RSET)
)

  ;取出表中的元素值
(defun TBC:DXF (code lst)
  (cdr (assoc code lst))
)

  ;取出表中的同一代码的多个元素值
(defun TBC:mDXF        (code en / tmp i lst)
  (setq i 0)
  (while (setq i (TBC:FindAt code en i))
    (setq tmp (cdr (nth i en))
          i   (1+ i)
          lst (append lst (list tmp))
    )
  )
  lst
)

  ;执行Command函数
(defun TBC:Command (paralist varlist / tmp i n el oldvar)
  (setq        varlist        (append varlist (list (list "CMDECHO" 0)))
        n        (length varlist)
        i        0
  )
  (while (< i n)
    (setq el         (nth i varlist)
          tmp         (list (getvar (car el)))
          oldvar (append oldvar tmp)
          i         (1+ i)
    )
    (setvar (car el) (cadr el))
  )
  (foreach el paralist (command el))
  (setq i 0)
  (while (< i n)
    (setq el  (nth i varlist)
          tmp (nth i oldvar)
          i   (1+ i)
    )
    (setvar (car el) tmp)
  )
)

flytodayddc

用不了…………………

flytodayddc

高手们都哪去了……………

flytodayddc

看来往日不复存在

炫翔

flytodayddc 发表于 2013-4-7 00:21

                               
登录/注册后可看大图

看来往日不复存在

刚刚重开没多久，在慢慢的恢复中......

cuyongping

喜欢！呵呵