[LISP]R2005 TABLE提取圖面中所有帶屬性圖塊值並表列

龙龙仔 发表于 2004-4-7 07:58:00

;;提取圖面中所有帶屬性圖塊值並表列
;;BY龍龍仔(LUCAS)
;;供測試未完善
(defun C:TT (/ WE N1 EE TITLE INSPT MSPACE TABLE N NN)
(setq WE (TT))
(setq N1 0)
(repeat (length WE)
   (setq EE (ssget "x"
      (list '(0 . "insert")
      '(66 . 1)
      (cons 2 (nth N1 WE))
      )
      )
   )
   (setq TITLE (VXGETATTS (vlax-ename->vla-object (ssname EE N1))))
   (print TITLE)
   (setq INSPT (getpoint "\n請選擇表格插入點: "))
   (setq MSPACE (vla-get-modelspace
      (vla-get-activedocument (vlax-get-acad-object))
)
   )
   (setq TABLE(vla-addtable
   MSPACE
   (vlax-3d-point INSPT)
   (1+ (sslength EE))
   (length TITLE)
   10
   25
)
   )
   (vla-unmergecells TABLE 0 0 0 (1- (length TITLE)))
   (vla-setalignment TABLE 1 acmiddlecenter)
   (setq N 0)
   (foreach ENT TITLE
      (vla-settext TABLE 0 N ENT)
      (setq N (1+ N))
   )
   (setq NN 1
EL (sslength EE)
   )
   (repeat EL
      (setq TITLE
      (VXGETATTS1 (vlax-ename->vla-object (ssname EE (1- NN))))
      )
      (prompt (strcat "\n餘" (rtos (- EL NN) 2 0)))
      (setq N 0)
      (foreach ENT TITLE
(vla-settext TABLE NN N ENT)
(setq N (1+ N))
      )
      (setq NN (1+ NN))
   )
   (setq N1 (1+ N1))
)
(vlax-release-object MSPACE)
(princ)
);;TABLE list
(defun TABLE1 (S / D R)
(while (setq D (tblnext S (null D)))
   (setq R (cons (cdr (assoc 2 D)) R))
)
)(defun TT (/ BLOCK SS_BLOCK N BLK BLK_LIST ENT ENT1)
(setqBLOCK (vla-get-blocks
(vla-get-activedocument
   (vla-get-application
      (vlax-get-acad-object)
   )
)
         )
)
(setq SS_BLOCK (TABLE1 "block"))
(setq N 0)
(repeat (length SS_BLOCK)
   (setq BLK (vla-item BLOCK (setq ENT1 (nth N SS_BLOCK))))
   (if(/= (vla-get-count BLK) 0)
      (vlax-forENT BLK
(if (and (not (vl-position ENT1 BLK_LIST))
(= (vla-get-objectname ENT) "AcDbAttributeDefinition")
      )
(setq BLK_LIST (append BLK_LIST (list ENT1)))
)
      )
   )
   (setq N (1+ N))
)
BLK_LIST
)(defun VXGETATTS (OBJ)
(mapcar
   '(lambda (ATT)
         (vla-get-tagstring ATT)
      )
   (vlax-invoke OBJ "GetAttributes")
)
)(defun VXGETATTS1 (OBJ)
(mapcar
   '(lambda (ATT)
         (vla-get-textstring ATT)
      )
   (vlax-invoke OBJ "GetAttributes")
)
)

citykunan 发表于 2004-4-8 15:45:00

有没有适合2002的？

meflying 发表于 2004-4-8 16:11:00

2004还没有table这种对象类型

byhabyh 发表于 2004-4-8 19:33:00

太好了，我正在对这样的问题苦恼呢！可是楼主的程序为什么不加入标注解释部分呢？这样也好懂一些，或者讲一下编制的思路呢？期待楼主能够解释一下你的思路！

龙龙仔 发表于 2004-4-9 08:54:00

;;完整版功能暫定: ;;1.能自動調整欄寬 ;;2.可設定字型 ;;3.可設定字高 ;;4.可選擇插入所有圖塊列表 or 單一圖塊列表 ;;5.增加進度條顯示 ;;6.插入Table能在所有空間使用 ;;7......暫無提供 8-(

mccad 发表于 2004-4-9 13:54:00

程序需要再完善： 1.程序是读取所有带属性图块的数量，但取属性值填表只取了第一种图块，就象我程序中有A块和B块，取到A块后，不会再去读B块。所以最后的表格没有填满。所以象我写的那样，让用户选择要输出的哪种块比较好。 2.字体没有调整，显得表格大，字体小。 3.应该把Header行隐去，保存Data和Title行。这样才可以避免数据行的格式不一致。

龙龙仔 发表于 2004-4-9 16:54:00

本帖最后由作者于 2004-4-10 8:06:17 编辑 1. SORRY!COPY漏一行!(第一版就可以列出所有圖塊屬性,這版怎可能沒有呢!) (repeat (length WE) (setq EE (ssget "x" (list '(0 . "insert") '(66 . 1) (cons 2 (nth N1 WE)) ) ) ) (setq TITLE (VXGETATTS (vlax-ename->vla-object (ssname EE 1));注意:N1→1 vla-get-tagstring ;提取屬性標題 ) )

2.& 3. 把屬性分開寫就會有效(title & header & data),沒必要把Header行隱去

(vla-unmergecells TABLE 0 0 0 (1- (length TITLE))) ;首行合併 (vla-setalignment TABLE 2 acmiddlecenter) ;增加 (vla-setalignment TABLE 4 acmiddlecenter) ;增加 (vla-setalignment TABLE 1 acmiddlecenter) ;增加 (vla-settextheight TABLE 2 5) ;增加 (vla-settextheight TABLE 4 5) ;增加 (vla-settextheight TABLE 1 5) ;增加

linear 发表于 2004-4-13 07:46:00

喜欢这样的句子：

且放白鹿青崖间，须行即骑访名山。 安能摧眉折腰事权贵，使我不得开心颜！

yxl88168 发表于 2011-3-31 19:33:45

谢谢楼主，这真是个好程序

daiguafan 发表于 2011-6-7 16:27:17

程序很不错，期待高手继续更新，完善

页: [1] 2

明经CAD社区's Archiver

[LISP]R2005 TABLE提取圖面中所有帶屬性圖塊值並表列