简单适用-画表格函数 非AcDbTable
本帖最后由 wzg356 于 2022-3-17 12:12 编辑简单适用-画表格函数非AcDbTable，后面例举3个应用场景
最后一个例子有动态感
类似功能函数论坛内很多了，分享我的版本，一直在用
如觉得ok!,你的赞或回复也许会成就另一位需要的朋友！！
=============
;写简易表格函数writetable
;datalst 元素均为字符串的数据表, 一行一子表
;子表长度可不等，以最大列数画表格
;zg字高，pt表格左上角基点
;wlst列宽表(list 5 10...),第0元素/第1列宽，依次类推，最大索引的值代表其之后的列宽
;dz:对正，T对正表格中央 nil对正表格左中
;即列宽表可以指定1个或多个值
;列宽推荐：最长字符长度*字高*0.5+2*子高
;行高不设参数，默认=字高*2.5
(defun writetable (datals wlst pt zg dz /hg lastw i date n w str w0 pt1 pt2 pt3)
(setqhg (* zg 2.5) lastw (last wlst) i 0)
(foreach date datals
(setq n 0w 0);单行操作开始
(foreach strdate ;
(or (setq w0(nth n wlst))(setq w0 lastw));列宽
(setq w (+ w w0));列位置
(setq pt3(mapcar '+ pt(list w (* i hg -1))));单格右上角
(setq pt1(mapcar '- pt3 (list w0 hg)));左下角
(setq pt2(mapcar '+ pt1 (list (* 0.5 w0) (* 0.5 hg))))
(if dz
(entmake (list '(0 . "TEXT") (cons 1 str) (cons 10 pt2) (cons 40 zg)
'(41 . 0.8)(cons 7(getvar 'textstyle))'(72 . 1)(cons 11 pt2)'(73 . 2))
);当前字体, 对正中央
(entmakex (list '(0 . "text") (cons 1 str) (cons 7 (getvar "textstyle"))
(cons 10 (mapcar '+ pt1 (list (* 0.5 zg) (* 0.5 zg))))(cons 40 zg)'(41 . 0.8))
);当前字体, 对正左下
)
(entmake(append
'((0 . "LWPOLYLINE")(100 . "AcDbEntity")(100 . "AcDbPolyline")(90 . 4)(70 . 1))
(mapcar '(lambda (x)(cons 10 x))
(list pt1 (list (car pt1)(cadr pt3))pt3(list (car pt3)(cadr pt1)))))
);画单格框
(setq n (1+ n))
)(setq i (1+ i))
)
)
;取得列表各列字串长(TableRwith lst)
(defun TableRwith (lst /a w wls)
(repeat
(apply 'max (mapcar 'length lst));列数
(setq a (subst "" nil(mapcar 'car lst)));列元素
(setq w(apply 'max (mapcar 'strlen a)));最大串长
(setq lst (mapcar 'cdr lst))
(setq wls (append wls (list w)))
)
)
;===============================
(vl-load-com)
;应用1 写表格
(defun c:ttt ( / lst zg pt wls)
(setq lst(mapcar '(lambda(x) (mapcar 'vl-princ-to-string x))
'(("字段1" "字段2" "字段3" "字段4" "字段5")
("as" "dfghj" "wertty" 3.445 16889)
("as" "dfghj" "wertty" 3.445 16889)
("格式化输入" "dfge" "edeer" 4568 132))
))
(and(setq zg(getreal "输入子高"))
(setq pt(getpoint "指定表格左上角"))
(setq wls(mapcar '(lambda(x)(+ (* 2 zg)(* x zg 0.5)))(TableRwith lst)))
;列宽:最长字符长度*字高*0.5+2*子高
(writetable lst wls pt zg nil)
)
)
;应用2选线写坐标表 子高默认5
(defun c:zbbg ( / e i pt lst wls bl)
(if(setq e (ssget ":S" '((0 . "*POLYLINE"))))
(progn
(setq e (ssname e 0) i -1)
(setvar "dimzin" 1)
(while(setq pt(vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst(cons(list(itoa(1+ i)) (rtos(cadr pt)2 2)(rtos(car pt)2 2)) lst))
)
(setq lst (cons (list "序号" "X(m)" "Y(m)") (reverse lst)))
(setq wls(mapcar '(lambda(i)(* i 4))(TableRwith lst)))
(and(setq pt(getpoint "指定表格左上角"))
(writetable lst wls pt 5 t)
)
)
)
)
;应用3选点写坐标表子高默认5 有动态感觉
(defun c:dzb ( / pt0 n)
(setvar "cmdecho" 0)(setvar "dimzin" 1)
(and(setq pt0(getpoint "指定表格左上角"))
(writetable '(("序号" "X(m)" "Y(m)"))(list 15 25) pt0 5 t)
(setq n 1)
(while (setq pt(getpoint "点取坐标位置"))
(writetable
(list(list(itoa n)(rtos(cadr pt)2 2)(rtos(car pt)2 2)))
(list 15 25) (mapcar '- pt0 (list 0 (* n 12.5))) 5 t
)
(command "_text" "bl" "non" pt5 0 (itoa n))
;坐标点处写编号
(setq n (1+ n))
)
)(setvar "cmdecho" 1)
)
xyp1964 发表于 2022-3-17 12:14
应用3，(list 15 25) ，当坐标点离原点比较远时文字会出边框。
建议：1.加进群组功能；2.多段线改直线。
谢谢大佬的点评！！！！
这是我库存，以往我的使用环境一直未发现该问题，抽空再改 应用3，(list 15 25) ，当坐标点离原点比较远时文字会出边框。
建议：1.加进群组功能；2.多段线改直线。
点坐标时候，编号和坐标点距离相当的远哦，不知道怎么设置 讚..................讚................... 还能优化更好吗 列钢筋表，正好用到了，感谢 谢谢楼主分享 这个东西不错，值得继续开发 谢谢分享表格函数 谢谢楼主分享
页:
[1]
2