[函数]提供一个表格函数

龙龙仔 · 发表于 2005-12-12 12:40:00

;;很多时候都会用到表格
;;提供一个表格函数(从表格系列程序分离出来!)
;;表格能自动调整(单行) "行宽" & "列高"----Autofit Cells
;;BY:龙龙仔(LUCAS)
;;For R2005~R2006 Only!!
;;资料列:'(("序号" "序号1" "序号2" "序号3" "序号4") ;标题
;; ("1" "111111111111111" "3434234" "4356456456" "23423423")
;; ("2" "2" "2" "2" "2"))
;;(TABLE_UTIL <资料列> <插入点> <字型> <字高>)
;;回传值:TABLE物件
;;使用例---统计圆
(defun C:TABLE_CIRCLE (/ LST INSPT TABLE)
;;---------------------------------------------------------
;;填表的资料要先处理好
(setq LST (vl-sort (MAKE_LIST)
(function
(lambda (E1 E2)
(< (atof (nth 2 E1)) (atof (nth 2 E2)))
)
)
)
)
(setq LST (append '(("X座标" "Y座标" "半径")) LST))
;;---------------------------------------------------------
(setq INSPT (getpoint "\n表格插入点/<ENTER 放弃>: "))
(if INSPT
(progn
(setq TABLE (TABLE_UTIL LST INSPT "STANDARD" 3))
;;DO SOMETHING FOR TABLE---如比例调整
(vla-scaleentity
TABLE
(vlax-3d-point INSPT)
(getvar "dimscale")
)
)
)
;;---------------------------------------------------------
(princ)
)
(defun MAKE_LIST (/ CEN CENX CENY ENT N RAD R_LIST SS TMP)
(if (setq SS (ssget "X" '((0 . "CIRCLE"))))
(progn
(setq N 0)
(repeat (sslength SS)
(setq CEN (cdr (assoc 10 (setq ENT (entget (ssname SS N))))))
(setq CENX (rtos (car CEN) 2 3))
(setq CENY (rtos (cadr CEN) 2 3))
(setq RAD (rtos (cdr (assoc 40 ENT)) 2 3))
(setq TMP (list CENX CENY RAD))
(setq R_LIST (cons TMP R_LIST))
(setq N (1+ N))
)
)
)
R_LIST
)
;;-----------------------------------------------------------
;;使用例---PLINE座标
(defun C:TABLE_PLINE (/ LST INSPT TABLE X HOLDZIN)
;;---------------------------------------------------------
;;填表的资料要先处理好
(setq HOLDZIN (getvar "DIMZIN"))
(setvar "DIMZIN" 0)
(setq LST (mapcar '(lambda (X)
(list (rtos (car X) 2 3)
(rtos (cadr X) 2 3)
(rtos (last X) 2 3)
)
)
(COORDS (car (entsel "\n选取Pline: ")))
)
)
(setvar "DIMZIN" HOLDZIN)
(setq LST (append '(("X座标" "Y座标" "Z座标")) LST))
;;---------------------------------------------------------
(setq INSPT (getpoint "\n表格插入点/<ENTER 放弃>: "))
(if INSPT
(progn
(setq TABLE (TABLE_UTIL LST INSPT "STANDARD" 3))
;;DO SOMETHING FOR TABLE---如比例调整
(vla-scaleentity
TABLE
(vlax-3d-point INSPT)
(getvar "dimscale")
)
)
)
;;---------------------------------------------------------
(princ)
)
;;By LUCAS
;;For Polylines & LWpolylines & 3Dpolylines
(defun COORDS (PLINE / ENDPARAM PARAM LST)
(setq ENDPARAM (vlax-curve-getendparam PLINE)
PARAM -1
)
(while (<= (setq PARAM (1+ PARAM)) ENDPARAM)
(setq LST (cons (vlax-curve-getpointatparam PLINE PARAM) LST)
)
)
(if (= 1 (logand (cdr (assoc 70 (entget PLINE))) 1))
(setq LST (reverse (cdr LST)))
(setq LST (reverse LST))
)
)
;;-------------------------------------------------------------

;;很多时候都会用到表格
;;提供一个表格函数(从表格系列程序分离出来!)
;;表格能自动调整(单行) "行宽" & "列高"----Autofit Cells
;;BY:龙龙仔(LUCAS)
;;For R2005~R2006 Only!!
;;资料列:'(("序号" "序号1" "序号2" "序号3" "序号4") ;标题
;;    ("1" "111111111111111" "3434234" "4356456456" "23423423")
;;         ("2" "2" "2" "2" "2"))
;;(TABLE_UTIL <资料列> <插入点> <字型> <字高>)
;;回传值:TABLE物件

;;使用例---统计圆
(defun C:TABLE_CIRCLE (/ LST INSPT TABLE)
  ;;---------------------------------------------------------
  ;;填表的资料要先处理好
  (setq LST (vl-sort (MAKE_LIST)
       (function
         (lambda (E1 E2)
    (< (atof (nth 2 E1)) (atof (nth 2 E2)))
         )
       )
     )
  )
  (setq LST (append '(("X座标" "Y座标" "半径")) LST))
  ;;---------------------------------------------------------
  (setq INSPT (getpoint "\n表格插入点/<ENTER 放弃>: "))
  (if INSPT
    (progn
      (setq TABLE (TABLE_UTIL LST INSPT "STANDARD" 3))
      ;;DO SOMETHING FOR TABLE---如比例调整
      (vla-scaleentity
 TABLE
 (vlax-3d-point INSPT)
 (getvar "dimscale")
      )
    )
  )
  ;;---------------------------------------------------------
  (princ)
)
(defun MAKE_LIST (/ CEN CENX CENY ENT N RAD R_LIST SS TMP)
  (if (setq SS (ssget "X" '((0 . "CIRCLE"))))
    (progn
      (setq N 0)
      (repeat (sslength SS)
 (setq CEN (cdr (assoc 10 (setq ENT (entget (ssname SS N))))))
 (setq CENX (rtos (car CEN) 2 3))
 (setq CENY (rtos (cadr CEN) 2 3))
 (setq RAD (rtos (cdr (assoc 40 ENT)) 2 3))
 (setq TMP (list CENX CENY RAD))
 (setq R_LIST (cons TMP R_LIST))
 (setq N (1+ N))
      )
    )
  )
  R_LIST
)
;;-----------------------------------------------------------
;;使用例---PLINE座标
(defun C:TABLE_PLINE (/ LST INSPT TABLE X HOLDZIN)
  ;;---------------------------------------------------------
  ;;填表的资料要先处理好
  (setq HOLDZIN (getvar "DIMZIN"))
  (setvar "DIMZIN" 0)
  (setq LST (mapcar '(lambda (X)
         (list (rtos (car X) 2 3)
        (rtos (cadr X) 2 3)
        (rtos (last X) 2 3)
         )
       )
      (COORDS (car (entsel "\n选取Pline: ")))
     )
  )
  (setvar "DIMZIN" HOLDZIN)
  (setq LST (append '(("X座标" "Y座标" "Z座标")) LST))
  ;;---------------------------------------------------------
  (setq INSPT (getpoint "\n表格插入点/<ENTER 放弃>: "))
  (if INSPT
    (progn
      (setq TABLE (TABLE_UTIL LST INSPT "STANDARD" 3))
      ;;DO SOMETHING FOR TABLE---如比例调整
      (vla-scaleentity
 TABLE
 (vlax-3d-point INSPT)
 (getvar "dimscale")
      )
    )
  )
  ;;---------------------------------------------------------
  (princ)
)
;;By LUCAS
;;For Polylines & LWpolylines & 3Dpolylines
(defun COORDS (PLINE / ENDPARAM PARAM LST)
  (setq ENDPARAM (vlax-curve-getendparam PLINE)
 PARAM  -1
  )
  (while (<= (setq PARAM (1+ PARAM)) ENDPARAM)
    (setq LST (cons (vlax-curve-getpointatparam PLINE PARAM) LST)
    )
  )
  (if (= 1 (logand (cdr (assoc 70 (entget PLINE))) 1))
    (setq LST (reverse (cdr LST)))
    (setq LST (reverse LST))
  )
)
;;-------------------------------------------------------------

tctabc · 发表于 2005-12-12 12:43:00

好东西

谢谢了~

gazkc · 发表于 2005-12-12 22:29:00

下来看看.谢谢

CADghost · 发表于 2005-12-13 14:21:00

TABLE_UTIL

这个函数没有定义呀？？

ZHAOXGOK · 发表于 2005-12-13 14:48:00

好东西，先顶了！

gjh · 发表于 2005-12-13 14:59:00

同时加载使用例.lsp和.vlx

C:TABLE_CIRCLE

C:TABLE_PLINE OK!

谢谢版主！

龙龙仔 · 发表于 2005-12-14 14:25:00

;;再来一个使用例----提取图面中所有带属性图块
;;并以表格画出(只要好好利用TABLE_UTIL函数程序就会写出来了!)
;;BY龙龙仔(LUCAS)
;;可在下列连结找到TABLE_UTIL的前身(源码),当年程序写得有点乱!
;;http://bbs.mjtd.com/forum.php?mod=viewthread&tid=19054
;;目前版本功能:(无对话框)
;;1.能自动调整栏宽
;;2.可设定字型
;;3.可设定字高
;;4.可选择插入所有图块列表 or 单一图块列表
;;5.增加进度显示
;;6.插入Table能在所有空间使用
;;7.现在提供 8-)
(defun C:TABLE_ATTBLOCK (/ EE INSPT LST N NN TABLE)
(vl-load-com)
(if (setq SUM (BLK_LIST))
(foreach NAME SUM
(setq
EE (ssget "x"
(list '(0 . "insert")
'(66 . 1)
(cons 2 NAME)
(cons 410 (getvar "ctab"))
)
)
)
(setq N 0)
(setq NN 0)
(repeat (sslength EE)
(setq LST
(cons
(VXGETATTS vla-get-textstring
(vlax-ename->vla-object (ssname EE NN))
)
LST
)
)
(setq NN (1+ NN))
)
(setq
LST (append
(list (VXGETATTS vla-get-tagstring
(vlax-ename->vla-object (ssname EE N))
)
)
LST
)
)
;;---------------------------------------------------------
(setq INSPT
(getpoint (strcat "\n属性图块""
NAME
""表格插入点/<ENTER 放弃>: "
)
)
)
(if INSPT
(progn
(setq TABLE (TABLE_UTIL LST INSPT "STANDARD" 3))
;;DO SOMETHING FOR TABLE---如比例调整
(vla-scaleentity
TABLE
(vlax-3d-point INSPT)
(getvar "dimscale")
)
)
)
;;---------------------------------------------------------
(setq N (1+ N)
LST NIL
LST1 NIL
)
)
)
(princ)
)
;;BY LUCAS
;;表列目前空间的属性图块
(defun BLK_LIST (/ N NAME SS B_LIST)
(setq N 0)
(setq SS
(ssget "x"
(list '(0 . "insert") '(66 . 1) (cons 410 (getvar "ctab")))
)
)
(repeat (sslength SS)
(if (not
(member (setq NAME (cdr (assoc 2 (entget (ssname SS N)))))
B_LIST
)
)
(setq B_LIST (cons NAME B_LIST))
)
(setq N (1+ N))
)
B_LIST
)
;;BY LUCAS
;;取出属性性质
(defun VXGETATTS (PRO OBJ)
(mapcar
'(lambda (ATT)
((eval PRO) ATT)
)
(vlax-invoke OBJ "GetAttributes")
)
)

;;再来一个使用例----提取图面中所有带属性图块
;;并以表格画出(只要好好利用TABLE_UTIL函数程序就会写出来了!)
;;BY龙龙仔(LUCAS)
;;可在下列连结找到TABLE_UTIL的前身(源码),当年程序写得有点乱!
;;http://bbs.mjtd.com/forum.php?mod=viewthread&tid=19054
;;目前版本功能:(无对话框)
;;1.能自动调整栏宽
;;2.可设定字型
;;3.可设定字高
;;4.可选择插入所有图块列表 or 单一图块列表
;;5.增加进度显示
;;6.插入Table能在所有空间使用
;;7.现在提供 8-)
(defun C:TABLE_ATTBLOCK (/ EE INSPT LST N NN TABLE)
  (vl-load-com)
  (if (setq SUM (BLK_LIST))
    (foreach NAME SUM
      (setq
 EE (ssget "x"
    (list '(0 . "insert")
   '(66 . 1)
   (cons 2 NAME)
   (cons 410 (getvar "ctab"))
    )
    )
      )
      (setq N 0)
      (setq NN 0)
      (repeat (sslength EE)
 (setq LST
        (cons
   (VXGETATTS vla-get-textstring
       (vlax-ename->vla-object (ssname EE NN))
   )
   LST
        )
 )
 (setq NN (1+ NN))
      )
      (setq
 LST (append
       (list (VXGETATTS vla-get-tagstring
          (vlax-ename->vla-object (ssname EE N))
      )
       )
       LST
     )
      )
      ;;---------------------------------------------------------
      (setq INSPT
      (getpoint (strcat "\n属性图块""
          NAME
          ""表格插入点/<ENTER 放弃>: "
         )
      )
      )
      (if INSPT
 (progn
   (setq TABLE (TABLE_UTIL LST INSPT "STANDARD" 3))
   ;;DO SOMETHING FOR TABLE---如比例调整
   (vla-scaleentity
     TABLE
     (vlax-3d-point INSPT)
     (getvar "dimscale")
   )
 )
      )
      ;;---------------------------------------------------------
      (setq N  (1+ N)
     LST  NIL
     LST1 NIL
      )
    )
  )
  (princ)
)
;;BY LUCAS
;;表列目前空间的属性图块
(defun BLK_LIST (/ N NAME SS B_LIST)
  (setq N 0)
  (setq SS
  (ssget "x"
  (list '(0 . "insert") '(66 . 1) (cons 410 (getvar "ctab")))
  )
  )
  (repeat (sslength SS)
    (if (not
   (member (setq NAME (cdr (assoc 2 (entget (ssname SS N)))))
    B_LIST
   )
 )
      (setq B_LIST (cons NAME B_LIST))
    )
    (setq N (1+ N))
  )
  B_LIST
)
;;BY LUCAS
;;取出属性性质
(defun VXGETATTS (PRO OBJ)
  (mapcar
    '(lambda (ATT)
       ((eval PRO) ATT)
     )
    (vlax-invoke OBJ "GetAttributes")
  )
)

龙龙仔 · 发表于 2006-6-2 15:22:00

;;使用例,总计图块并在侧展示略图
;;By LUCAS(龙龙仔)
(defun C:STATISTICS (/ BLKS INSPT LST LST1 LSTT N
NAME OBJECTID ROW SS ST SUM
TABLE
)
(vl-load-com)
(if (not (member 'TABLE_UTIL (vl-list-loaded-vlx)))
(load (findfile "table_util.vlx") NIL)
)
(prompt "\n选择图块: ")
(if (setq SS (ssget '((0 . "insert"))))
(progn
(setq LST1 '(("略图" "名称" "数量" "备註")))
(setq N 0)
(repeat (sslength SS)
(if (assoc (setq NAME (cdr (assoc 2 (entget (ssname SS N)))))
LST
)
(setq LST
(subst (cons NAME (1+ (cdr (setq ST (assoc NAME LST)))))
ST
LST
)
)
(setq LST (cons (cons NAME 1) LST))
)
(setq N (1+ N))
)
(setq LST (vl-sort LST
(function (lambda (E1 E2)
(< (car E1) (car E2))
)
)
)
)
(setq SUM 0)
(foreach ENT LST
(setq SUM (+ SUM (cdr ENT)))
(setq LSTT (cons (list "" (car ENT) (cdr ENT)) LSTT))
)
(setq LST (cons (list "" "合计" SUM) LSTT))
(setq LST (append LST1 (reverse LST)))
(setq INSPT (getpoint "\n表格插入点/<ENTER 放弃>: "))
(if INSPT
(progn
;;(TABLE_UTIL <资料列> <插入点> <字型> <字高>)
(setq TABLE (TABLE_UTIL LST INSPT "STANDARD" 3))
;;DO SOMETHING FOR TABLE---如比例调整
(vla-scaleentity
TABLE
(vlax-3d-point INSPT)
(getvar "dimscale")
)
(setq BLKS (vla-get-blocks
(vla-get-activedocument
(vlax-get-acad-object)
)
)
)
(setq ROW (- (length LST) 2))
;;R2006(含)以上才有REGENERATETABLESUPPRESSED属性
(if (> (atof (getvar "ACADVER")) 16.1)
(VLA-PUT-REGENERATETABLESUPPRESSED TABLE :vlax-true)
)
(repeat ROW
(setq OBJECTID (vla-get-objectid
(vla-item BLKS (vla-gettext TABLE ROW 1))
)
)
(vla-setcelltype TABLE ROW 0 1)
(vla-setblocktablerecordid TABLE ROW 0 OBJECTID :vlax-true)
(vla-setautoscale TABLE ROW 0 :vlax-true)
(setq ROW (1- ROW))
)
(if (> (atof (getvar "ACADVER")) 16.1)
(VLA-PUT-REGENERATETABLESUPPRESSED TABLE :vlax-false)
)
(vlax-release-object BLKS)
)
)
)
)
(princ)
)
(princ "\nType Statistics,By LUCAS")
(princ)

;;使用例,总计图块并在侧展示略图
;;By LUCAS(龙龙仔)
(defun C:STATISTICS (/     BLKS   INSPT  LST  LST1 LSTT   N
       NAME   OBJECTID   ROW  SS ST     SUM
       TABLE
      )
  (vl-load-com)
  (if (not (member 'TABLE_UTIL (vl-list-loaded-vlx)))
    (load (findfile "table_util.vlx") NIL)
  )
  (prompt "\n选择图块: ")
  (if (setq SS (ssget '((0 . "insert"))))
    (progn
      (setq LST1 '(("略图" "名称" "数量" "备註")))
      (setq N 0)
      (repeat (sslength SS)
 (if (assoc (setq NAME (cdr (assoc 2 (entget (ssname SS N)))))
     LST
     )
   (setq LST
   (subst (cons NAME (1+ (cdr (setq ST (assoc NAME LST)))))
   ST
   LST
   )
   )
   (setq LST (cons (cons NAME 1) LST))
 )
 (setq N (1+ N))
      )
      (setq LST (vl-sort LST
    (function (lambda (E1 E2)
         (< (car E1) (car E2))
       )
    )
  )
      )
      (setq SUM 0)
      (foreach ENT LST
 (setq SUM (+ SUM (cdr ENT)))
 (setq LSTT (cons (list "" (car ENT) (cdr ENT)) LSTT))
      )
      (setq LST (cons (list "" "合计" SUM) LSTT))
      (setq LST (append LST1 (reverse LST)))
      (setq INSPT (getpoint "\n表格插入点/<ENTER 放弃>: "))
      (if INSPT
 (progn
   ;;(TABLE_UTIL <资料列> <插入点> <字型> <字高>)
   (setq TABLE (TABLE_UTIL LST INSPT "STANDARD" 3))
   ;;DO SOMETHING FOR TABLE---如比例调整
   (vla-scaleentity
     TABLE
     (vlax-3d-point INSPT)
     (getvar "dimscale")
   )
   (setq BLKS (vla-get-blocks
         (vla-get-activedocument
    (vlax-get-acad-object)
         )
       )
   )
   (setq ROW (- (length LST) 2))
   ;;R2006(含)以上才有REGENERATETABLESUPPRESSED属性
   (if (> (atof (getvar "ACADVER")) 16.1)
     (VLA-PUT-REGENERATETABLESUPPRESSED TABLE :vlax-true)
   )
   (repeat ROW
     (setq OBJECTID (vla-get-objectid
        (vla-item BLKS (vla-gettext TABLE ROW 1))
      )
     )
     (vla-setcelltype TABLE ROW 0 1)
     (vla-setblocktablerecordid TABLE ROW 0 OBJECTID :vlax-true)
     (vla-setautoscale TABLE ROW 0 :vlax-true)
     (setq ROW (1- ROW))
   )
   (if (> (atof (getvar "ACADVER")) 16.1)
     (VLA-PUT-REGENERATETABLESUPPRESSED TABLE :vlax-false)
   )
   (vlax-release-object BLKS)
 )
      )
    )
  )
  (princ)
)
(princ "\nType Statistics,By LUCAS")
(princ)

无痕 · 发表于 2006-6-2 18:58:00

看起来不错！

严重支持龙龙仔！

别晨 · 发表于 2006-6-2 20:08:00

看起来有点拽^_^

账号		自动登录	找回密码
密码			注册

[函数]提供一个表格函数

本帖子中包含更多资源

本帖被以下淘专辑推荐:

本帖子中包含更多资源

本帖子中包含更多资源

浏览过的版块