简单适用-画表格函数 非AcDbTable

admin

5. 简单适用-画表格函数  非AcDbTable，后面例举3个应用场景
6. 最后一个例子有动态感
8. 类似功能函数论坛内很多了，分享我的版本，一直在用
10. 如觉得ok!,你的赞或回复也许会成就另一位需要的朋友！！
12. =============
14. ;写简易表格函数writetable
15. ;datalst 元素均为字符串的数据表, 一行一子表
16. ;子表长度可不等，以最大列数画表格
17. ;zg字高，pt表格左上角基点
18. ;wlst列宽表(list 5 10...),第0元素/第1列宽，依次类推，最大索引的值代表其之后的列宽
19. ;dz:对正，T对正表格中央 nil对正表格左中
20. ;即列宽表可以指定1个或多个值
21. ;列宽推荐：最长字符长度*字高*0.5+2*子高
22. ;行高不设参数，默认=字高*2.5
23. (defun writetable (datals wlst pt zg dz /  hg lastw i date n w str w0 pt1 pt2 pt3)
24.         (setq  hg (* zg 2.5) lastw (last wlst) i 0)
25.         (foreach date datals
26.                 (setq n 0  w 0);单行操作开始
27.                 (foreach str  date ;
28.                         (or (setq w0(nth n wlst))(setq w0 lastw));列宽
29.                         (setq w (+ w w0));列位置                        
30.                         (setq pt3(mapcar '+ pt(list w (* i hg -1))));单格右上角
31.                         (setq pt1(mapcar '- pt3 (list w0 hg)));左下角
32.                         (setq pt2(mapcar '+ pt1 (list (* 0.5 w0) (* 0.5 hg))))
33.                         (if dz
34.                                 (entmake (list '(0 . "TEXT") (cons 1 str) (cons 10 pt2) (cons 40 zg)
35.                                                 '(41 . 0.8)(cons 7(getvar 'textstyle))'(72 . 1)(cons 11 pt2)'(73 . 2))
36.                                 );当前字体, 对正中央
37.                                 (entmakex (list '(0 . "text") (cons 1 str) (cons 7 (getvar "textstyle"))
38.                                         (cons 10 (mapcar '+ pt1 (list (* 0.5 zg) (* 0.5 zg))))(cons 40 zg)'(41 . 0.8))
39.                                 );当前字体, 对正左下
40.                         )
41.                         (entmake(append
42.                                 '((0 . "LWPOLYLINE")(100 . "AcDbEntity")(100 . "AcDbPolyline")(90 . 4)(70 . 1))
43.                                 (mapcar '(lambda (x)(cons 10 x))
44.                                 (list pt1 (list (car pt1)(cadr pt3))pt3(list (car pt3)(cadr pt1)))))
45.                         );画单格框
46.                         (setq n (1+ n))
47.                 )(setq i (1+ i))
48.         )
49. )
50. ;取得列表各列字串长(TableRwith lst)
51. (defun TableRwith (lst /  a w wls)
52.     (repeat
53.             (apply 'max (mapcar 'length lst));列数
54.             (setq a (subst "" nil(mapcar 'car lst)));列元素
55.             (setq w(apply 'max (mapcar 'strlen a)));最大串长
56.             (setq lst (mapcar 'cdr lst))
57.             (setq wls (append wls (list w)))
58.     )
59. )
61. ;===============================
62. (vl-load-com)
63. ;应用1 写表格
64. (defun c:ttt ( / lst zg pt wls)
65.         (setq lst(mapcar '(lambda(x) (mapcar 'vl-princ-to-string x))
66.            '(("字段1" "字段2" "字段3" "字段4" "字段5")
67.                 ("as" "dfghj" "wertty" 3.445 16889)
68.                 ("as" "dfghj" "wertty" 3.445 16889)
69.                 ("格式化输入" "dfge" "edeer" 4568 132))
70.         ))
71.         (and(setq zg(getreal "输入子高"))
72.                 (setq pt(getpoint "指定表格左上角"))
73.                 (setq wls(mapcar '(lambda(x)(+ (* 2 zg)(* x zg 0.5)))(TableRwith lst)))
74.                 ;列宽:最长字符长度*字高*0.5+2*子高
75.                 (writetable lst wls pt zg nil)
76.         )
77. )
81. ;应用2选线写坐标表 子高默认5
82. (defun c:zbbg ( / e i pt lst wls bl)        
83.         (if(setq e (ssget ":S" '((0 . "*POLYLINE"))))
84.                 (progn
85.                 (setq e (ssname e 0) i -1)
86.                 (setvar "dimzin" 1)
87.                 (while(setq pt(vlax-curve-getpointatparam e (setq i (1+ i))))
88.                         (setq lst(cons(list(itoa(1+ i)) (rtos(cadr pt)2 2)(rtos(car pt)2 2)) lst))
89.                 )
90.                 (setq lst (cons (list "序号" "X(m)" "Y(m)") (reverse lst)))
91.                 (setq wls(mapcar '(lambda(i)(* i 4))(TableRwith lst)))
92.                 (and(setq pt(getpoint "指定表格左上角"))
93.                         (writetable lst wls pt 5 t)                        
94.                 )
95.                 )               
96.         )
97. )
98. ;应用3选点写坐标表  子高默认5 有动态感觉
99. (defun c:dzb ( / pt0 n)
100.         (setvar "cmdecho" 0)(setvar "dimzin" 1)
101.         (and(setq pt0(getpoint "指定表格左上角"))
102.                 (writetable '(("序号" "X(m)" "Y(m)"))(list 15 25) pt0 5 t)
103.                 (setq n 1)
104.                 (while (setq pt(getpoint "点取坐标位置"))
105.                         (writetable
106.                                 (list(list(itoa n)(rtos(cadr pt)2 2)(rtos(car pt)2 2)))
107.                                 (list 15 25) (mapcar '- pt0 (list 0 (* n 12.5))) 5 t
108.                         )
109.                         (command "采用text" "bl" "non" pt  5 0 (itoa n))
110.                         ;坐标点处写编号
111.                         (setq n (1+ n))                                
112.                 )
113.         )(setvar "cmdecho" 1)
114. )

复制代码