拷贝table的一部分

/db_自贡黄明儒_

;;不是太完善，也可以学到一点东西

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

;;拷贝一个单元到加一个单元<br /> (defun Copy-Cell-to-Cell (Table1 row1 col1 Table2 row2 col2 ColW)<br />   (vla-SetText<br />     Table2<br />     row2<br />     col2<br />     (vla-GetText Table1 row1 col1)<br />   )<br />   (vla-SetCellTextHeight<br />     Table2<br />     row2<br />     col2<br />     (vla-GetCellTextHeight Table1 row1 col1)<br />   )<br />   (vla-SetCellAlignment<br />     Table2<br />     row2<br />     col2<br />     (vla-GetCellAlignment Table1 row1 col1)<br />   )<br />   (if ColW<br />     (vla-setColumnWidth<br />       Table2<br />       col2<br />       (vla-GetColumnWidth Table1 col1)<br />     )<br />   )<br /> )<br /> <br /> (defun C:CPofTable (/ ACSP C CNT CNTCOL COLUMNWIDTH E1 E2 ECOL EROW MAXROW OBJ P1 P2 PT R ROWHEIGHT SCOL SROW TBLOBJ TEMPCNTCOL VWDIR)<br />   (or *ACAD* (setq *ACAD* (vlax-get-acad-object)))<br />   (or *DOC* (setq *DOC* (vla-get-ActiveDocument *ACAD*)))<br />   (setq        acsp (if (= (getvar "TILEMODE") 0)<br />                (vla-get-paperspace *DOC*)<br />                (vla-get-modelspace *DOC*)<br />              )<br />   )<br />   (setq VwDir (getvar 'ViewDir))<br />   (if (and<br />         (setq p1 (getpoint "\n Table上取一点:"))<br />         (setq e1 (ssname (ssget p1 '((0 . "ACAD_TABLE"))) 0))        <br />         (setq p2 (getcorner p1 "\n Table上取另一点:"))        <br />         (setq e2 (ssname (ssget p2 '((0 . "ACAD_TABLE"))) 0))<br />         (equal e1 e2)              ;同一个表<br />         (setq obj (vlax-ename->vla-object e1))<br />         (equal (vla-HitTest<br />                  Obj<br />                  (vlax-3d-point p1)<br />                  (vlax-3d-point VwDir)<br />                  'sRow<br />                  'sCol<br />                )<br />                :vlax-true<br />         )<br />         (equal (vla-HitTest<br />                  Obj<br />                  (vlax-3d-point p2)<br />                  (vlax-3d-point VwDir)<br />                  'eRow<br />                  'eCol<br />                )<br />                :vlax-true<br />         )<br />         sRow<br />         sCol<br />         eRow<br />         eCol<br />       )<br />     (progn      <br />       (setq MaxRow (abs (- sRow eRow)))  ;行差<br />       ;;如果没有选择到“标题”，则加一行做标题<br />       (if (/= (min sRow eRow) 0) (setq MaxRow (1+ MaxRow)))<br />       (setq sRow (min sRow eRow) eRow (+ sRow MaxRow))<br />       <br />       (setq cntCol (abs (- sCol eCol)));列差<br />       (setq sCol (min sCol eCol) eCol (+ sCol cntCol))<br />       ;最后一行一列的高度和宽度<br />       (setq RowHeight (vla-GetRowHeight obj eRow))<br />       (setq ColumnWidth (vla-getcolumnwidth obj eCol))<br />       (setq TblObj (vlax-invoke<br />                        acsp<br />                        'Addtable<br />                        (setq pt (cadr (grread T 8)))<br />                        MaxRow<br />                        cntCol<br />                        RowHeight<br />                        ColumnWidth<br />                      )<br />       )<br />       ;;处理标题,即第一行<br />       (if (equal (vla-get-TitleSuppressed obj) :vlax-false)<br />         (progn                                                              ;合并<br />           (vla-put-TitleSuppressed TblObj :vlax-false)<br />           (Copy-Cell-to-Cell obj 0 0 TblObj 0 0 nil)<br />         )<br />         (progn<br />           (setq cnt 0)<br />           (setq tempCntCol sCol)<br />           (repeat cntCol<br />             (Copy-Cell-to-Cell obj 0 tempCntCol TblObj 0 cnt nil)<br />             (setq cnt (1+ cnt))<br />             (setq tempCntCol (1+ tempCntCol))<br />           )<br />         )<br />       )<br /> <br />       (setq R 1)<br />       (repeat MaxRow<br />         (setq C 0)<br />         (setq tempCntCol sCol)<br />         (repeat        cntCol<br />           (Copy-Cell-to-Cell obj sRow tempCntCol TblObj R C nil)          <br />           (setq tempCntCol (1+ tempCntCol))<br />           (setq C(1+ C))<br />         )<br />         (setq sRow(1+ sRow))<br />         (setq R (1+ R))<br />       )<br />       ;;(vla-put-RegenerateTableSuppressed TblObj :vlax-false)<br />     )<br />   )<br />   (princ)<br /> )<br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;拷贝表中一部分

sicky111

这个厉害啦！