[求助]图块统计的小程序

jdyq

请龙龙仔斑竹编个小程序，统计图块的，思路是：先框选要统计图块的范围，确定后自动统计出数量，要将图块的名称，图层，数量输出到EXCEL，再次执行命令，再次需要统计的图块的名称，图层，数量输出到之前打开的EXCEL的另一个工作表中，（对于被冻结和被锁定的图层里的图块不进行统计），能帮帮我吗？

jdyq

这个程序对我来说确实有用,希望高手来解答,拜托了

xxsheng

(defun blktoale( / selfilter po1 po2 objsel objsellist numblist a n m tmp workbooks actworkbook
           worksheet relrow relcol)
  (setq selfilter(list (cons 0 "insert")))
  (prompt "\n选择要输出的对象<Exit退出>：")
  (initget 1 "Exit")
  (setq po1(getpoint))
  (if (= "Exit" po1) (vl-exit-with-error 1))
  (while (/= "Exit" po1)
    (setq po2(getcorner po1))
    (setq objsel(ssget "c" po1 po2 selfilter));框选块-----------------------
    (if (null objsel) (vl-exit-with-error 1));空选择也退出,否则会出错-------
    (setq n -1)
    (while (< (setq n(1+ n))(sslength objsel))
      (setq objsellist(cons (list (cdr(assoc '2 (entget(ssname objsel n))))
                  (cdr(assoc '8 (entget(ssname objsel n)))))
                objsellist))
    )
  ;得到块的名称和其层的列表objsellist---------------------------------------
  ;要得到数量还要进行列表objsellist的改造,如果名称和层相同则数量加1---------
  (setq numblist nil m 0 );这里也要重新设置为nil,否则会重复计算----------
  (foreach no objsellist
    (progn
      (if (= (vl-position no objsellist) m);说明前面没有名称和层相同的表---
    (progn
      (setq objsel objsellist)
      (setq objsel(vl-remove-if-not  '(lambda(x)(equal x no)) objsel))
      (setq numblist (cons (append no (list (length objsel))) numblist))
    )
    ;不存在相同的块--------------------------------------------------
      )
      (setq m (1+ m))
    )
 )
 ;得到名称,层,数量的列表newobjsellist,下面就是输出到excel的问题了--------
 (DSX-Load-TypeLib-Excel);导入excel库,-----------------------------------
 (setq excel(vlax-get-or-create-object "Excel.Application"))
 (vla-put-visible excel :vlax-true)
 (setq workbooks(vlax-get-property excel 'Workbooks))
 (setq actworkbook(vlax-invoke-method workbooks 'add))
 (setq worksheet(vlax-get-property excel 'activesheet))
 (vla-put-name worksheet "图块统计")
 ;上面新建文档,下面开始输入----------------------------------------------
 (setq relrow 1)
 (foreach x numblist
   (setq relcol 1)
   (foreach y x (msxl-put-value2 (vlax-variant-value
                                       (msxl-get-item (msxl-get-cells worksheet)
                                      (vlax-make-variant relrow)
                                      (vlax-make-variant relcol)))
                y
                )
                (setq relcol(1+ relcol))
     )  
    (setq relrow(1+ relrow))
 )
 (vlax-release-object excel)
 (prompt "\n选择要输出的对象<Exit退出>：")
 (initget 1 "Exit")
 (setq po1(getpoint))
 )
)

;以下采用自
;http://bbs.mjtd.com/forum.php?mod=viewthread&tid=57758&replyID=46333&skin=1
;改动了一下为注册表读取库,2003版本如果自定义安装的话还是注册表比较实用------
(defun DSX-Load-TypeLib-Excel ( / tlbfile tlbver out)
(cond
( (null msxl-xl24HourClock)
(if (findfile(setq tlbfile (strcat (vl-registry-read
                    "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\Excel.EXE"
                    "Path") "excel.exe")))
(progn
(setq tlbver (substr (vl-filename-base tlbfile) 6))
(cond
( (= tlbver "9")
(princ "\n初始化 Microsoft Excel 2000...") )
( (= tlbver "8")
(princ "\n初始化 Microsoft Excel 97...") )
( (= (vl-filename-base tlbfile) "Excel.exe")
(princ "\n初始化 Microsoft Excel XP...")
)
)
(vlax-import-type-library
:tlb-filename tlbfile
:methods-prefix "msxl-"
:properties-prefix "msxl-"
:constants-prefix "msxl-"
)
(if msxl-xl24HourClock (setq out T))
)
)
)
( T (setq out T) )
)
out
)

jdyq

谢谢您,是lisp吗,能请您做个附件吗

jdyq

blktoale 未知命令“BLKTOALE

jdyq

一切ok,终于搞定,谢谢xxsheng

jdyq

发现一个错误,本希望相同名称的块如果在不同的层中数量也能分开统计,但目前的程序将在不同的层中相同名称的块的数量进行了合并,期待各位高手帮忙解决

flytoday

这个用什么命令啊

vlisp2012

(defun blktoale( / selfilter po1 po2 objsel objsellist numblist a n m tmp workbooks actworkbook
           worksheet relrow relcol)
改成(defun c:blktoale( / selfilter po1 po2 objsel objsellist numblist a n m tmp workbooks actworkbook
           worksheet relrow relcol)
就可以用命令blktoale加载了。（另存为lsp文件）

motherland118

好东西，不错，学习学习