设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 59|回复: 1

[研讨] 拷贝table的一部分

[复制链接]

签到天数: 1280 天

连续签到: 2 天

[LV.10]以坛为家III

已领礼包: 604个

财富等级: 财运亨通

发表于 2017-10-12 22:01:33 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有帐号?立即注册

x
;;不是太完善,也可以学到一点东西
  1. ;;拷贝一个单元到加一个单元
  2. (defun Copy-Cell-to-Cell (Table1 row1 col1 Table2 row2 col2 ColW)
  3.   (vla-SetText
  4.     Table2
  5.     row2
  6.     col2
  7.     (vla-GetText Table1 row1 col1)
  8.   )
  9.   (vla-SetCellTextHeight
  10.     Table2
  11.     row2
  12.     col2
  13.     (vla-GetCellTextHeight Table1 row1 col1)
  14.   )
  15.   (vla-SetCellAlignment
  16.     Table2
  17.     row2
  18.     col2
  19.     (vla-GetCellAlignment Table1 row1 col1)
  20.   )
  21.   (if ColW
  22.     (vla-setColumnWidth
  23.       Table2
  24.       col2
  25.       (vla-GetColumnWidth Table1 col1)
  26.     )
  27.   )
  28. )

  29. (defun C:CPofTable (/ ACSP C CNT CNTCOL COLUMNWIDTH E1 E2 ECOL EROW MAXROW OBJ P1 P2 PT R ROWHEIGHT SCOL SROW TBLOBJ TEMPCNTCOL VWDIR)
  30.   (or *ACAD* (setq *ACAD* (vlax-get-acad-object)))
  31.   (or *DOC* (setq *DOC* (vla-get-ActiveDocument *ACAD*)))
  32.   (setq        acsp (if (= (getvar "TILEMODE") 0)
  33.                (vla-get-paperspace *DOC*)
  34.                (vla-get-modelspace *DOC*)
  35.              )
  36.   )
  37.   (setq VwDir (getvar 'ViewDir))
  38.   (if (and
  39.         (setq p1 (getpoint "\n Table上取一点:"))
  40.         (setq e1 (ssname (ssget p1 '((0 . "ACAD_TABLE"))) 0))       
  41.         (setq p2 (getcorner p1 "\n Table上取另一点:"))       
  42.         (setq e2 (ssname (ssget p2 '((0 . "ACAD_TABLE"))) 0))
  43.         (equal e1 e2)              ;同一个表
  44.         (setq obj (vlax-ename->vla-object e1))
  45.         (equal (vla-HitTest
  46.                  Obj
  47.                  (vlax-3d-point p1)
  48.                  (vlax-3d-point VwDir)
  49.                  'sRow
  50.                  'sCol
  51.                )
  52.                :vlax-true
  53.         )
  54.         (equal (vla-HitTest
  55.                  Obj
  56.                  (vlax-3d-point p2)
  57.                  (vlax-3d-point VwDir)
  58.                  'eRow
  59.                  'eCol
  60.                )
  61.                :vlax-true
  62.         )
  63.         sRow
  64.         sCol
  65.         eRow
  66.         eCol
  67.       )
  68.     (progn      
  69.       (setq MaxRow (abs (- sRow eRow)))  ;行差
  70.       ;;如果没有选择到“标题”,则加一行做标题
  71.       (if (/= (min sRow eRow) 0) (setq MaxRow (1+ MaxRow)))
  72.       (setq sRow (min sRow eRow) eRow (+ sRow MaxRow))
  73.       
  74.       (setq cntCol (abs (- sCol eCol)));列差
  75.       (setq sCol (min sCol eCol) eCol (+ sCol cntCol))
  76.       ;最后一行一列的高度和宽度
  77.       (setq RowHeight (vla-GetRowHeight obj eRow))
  78.       (setq ColumnWidth (vla-getcolumnwidth obj eCol))
  79.       (setq TblObj (vlax-invoke
  80.                        acsp
  81.                        'Addtable
  82.                        (setq pt (cadr (grread T 8)))
  83.                        MaxRow
  84.                        cntCol
  85.                        RowHeight
  86.                        ColumnWidth
  87.                      )
  88.       )
  89.       ;;处理标题,即第一行
  90.       (if (equal (vla-get-TitleSuppressed obj) :vlax-false)
  91.         (progn                                                              ;合并
  92.           (vla-put-TitleSuppressed TblObj :vlax-false)
  93.           (Copy-Cell-to-Cell obj 0 0 TblObj 0 0 nil)
  94.         )
  95.         (progn
  96.           (setq cnt 0)
  97.           (setq tempCntCol sCol)
  98.           (repeat cntCol
  99.             (Copy-Cell-to-Cell obj 0 tempCntCol TblObj 0 cnt nil)
  100.             (setq cnt (1+ cnt))
  101.             (setq tempCntCol (1+ tempCntCol))
  102.           )
  103.         )
  104.       )

  105.       (setq R 1)
  106.       (repeat MaxRow
  107.         (setq C 0)
  108.         (setq tempCntCol sCol)
  109.         (repeat        cntCol
  110.           (Copy-Cell-to-Cell obj sRow tempCntCol TblObj R C nil)          
  111.           (setq tempCntCol (1+ tempCntCol))
  112.           (setq C(1+ C))
  113.         )
  114.         (setq sRow(1+ sRow))
  115.         (setq R (1+ R))
  116.       )
  117.       ;;(vla-put-RegenerateTableSuppressed TblObj :vlax-false)
  118.     )
  119.   )
  120.   (princ)
  121. )
  122. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;拷贝表中一部分
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

签到天数: 1865 天

连续签到: 15 天

[LV.Master]伴坛终老I

已领礼包: 5570个

财富等级: 富甲天下

发表于 2017-10-13 07:05:39 | 显示全部楼层
这个厉害啦!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|小黑屋|手机版|Archiver|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )  

GMT+8, 2018-6-18 21:13 , Processed in 0.159935 second(s), 20 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表