悬赏面积统计输出EXCEL

为什么任兵

求各位高手帮忙
写一个LISP，要求很简单，
就这一个功能
请看图

直接框选，把框选里面的 面域面积统计出来
还有版号也是，
（我说有的图纸，版号都在面域里面的）

langjs

;;; 框选封闭区域面积到excel    by:langjs
;;; ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
(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)
)

为什么任兵

没有高手感兴趣吗？

lizhiqiang9801

为什么任兵 发表于 2012-2-13 21:06
没有高手感兴趣吗？

好程序 不知道怎么 我统计出输出到exce中个数翻倍  再提议一下 能把线长度加上，输出的单位是实际单位，再就是能输出到已打开的exce中吗？   多谢

zhouren_cmi

谢谢热心人分享源码

langjs

现学现卖

;;; 框选封闭区域面积到excel    by:langjs
;;; ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
(defun c:qq (/ appxls col ent ent1 ent2 f i lst lst1 m2 maxpoint minpoint na
        newbook newitem newsheet numrow pc pmax pmin pt sc snap ss
        txt value vh viewsize vw x xlscells xlsworkbooks y
     )
  (defun GetViewSize (/ pc vh sc vw vh pmin pmax)
    (setq pc (getvar "viewctr")
   vh (getvar "viewsize")
   sc (getvar "screensize")
   vw (* vh (/ (car sc) (cadr sc)))
   pmin (list (- (car pc) (* 0.5 vw)) (- (cadr pc) (* 0.5 vh)))
   pmax (list (+ (car pc) (* 0.5 vw)) (+ (cadr pc) (* 0.5 vh)))
    )
    (list pmin pmax)
  )
  (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)
    )
  )
  (vl-load-com)
  (setvar "cmdecho" 0)
  (setq snap (getvar "osmode"))        ; 关闭捕捉
  (setvar "osmode" 0)
  (if (setq ss (ssget '((0 . "*TEXT"))))
    (progn
      (setq ViewSize (GetViewSize))
      (setq lst1 '())
      (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 "")
(setq ent2 (entlast))
(if (= (cdr (assoc 0 (entget ent2))) "LWPOLYLINE")
   (progn
     (vla-getboundingbox (vlax-ename->vla-object ent2) 'minpoint
    'maxpoint
     )
     (setq pmax (vlax-safearray->list maxpoint)
    pmin (vlax-safearray->list minpoint)
     )
     (entdel ent2)
     (setq lst1 (cons (list pmin pmax pt txt) lst1))
   )
)
      )
      (= lst nil)
      (repeat (setq i (length lst1))
(setq na (nth (setq i (1- i))
        lst1
   )
       pmin (car na)
       pmax (cadr na)
       pt (caddr na)
       txt (cadddr na)
)
(command ".zoom" "W" pmin pmax)
(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) 2 2)
  lst (cons (list txt m2) lst)
  f (entdel ent1)
   )
)
      )
      (command ".zoom" "W" (car ViewSize) (cadr ViewSize))
      (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)
    )
  )
  (setvar "osmode" snap)        ; 恢复捕捉
  (princ)
)

lizhiqiang9801

langjs 发表于 2012-2-14 19:56
现学现卖

;;; 框选封闭区域面积到excel    by:langjs

多谢 辛苦了 能把线形长度也加上吗

springwillow

好东西，值得学习！

江湖远人

二楼犀利啊，顶起

lrd1861

输出excel目的是什么