引线标注点筋与线筋源码解析（支持UCS）
本帖最后由 林霄云 于 2014-4-23 22:09 编辑引线标注点筋与线筋源码解析（支持UCS）
我曾说，我会离开lisp。谁又知道我从软件工程转土木工程有多难，又知道我内心有燃烧过那热火。——记录与真实生活
闲话少说，看正文。
思路
将标注点筋和线筋（一个标根数一个是标间距）集成在一起。应该做如下几件事：
1，选择后的选择集，自动判断是标注点筋还是线筋。
如果有点筋，标注点筋，如果没有点筋，标注线筋。
2，引线自动生成。
对于点筋，取点筋中点，如果是块，该是插入点，作为引线一端。对于线筋，取选择框中点距对象最近的点。且各自成前处理函数，生成点表。
取点筋点表(defun get_bar_ptlist( ss / pt_list pt en ent ptli )
;函数get_bar_ptlist，参数ss 选择集。返回值，点筋点表。
;Desiged by 林霄云 2014年2月10日取线筋点表(defun get_linebar_pt( ss / pt sslist )
;Designed by 林霄云 2014年4月20日
;取线筋接触点。多选时，仅支持取第一根3，动态处理文字位置，且为当前UCS下，支持90度旋转
对文字及文字下划线，拖动模式，更新其坐标点。旋转时，亦更新相应坐标点。
4，支持平行引线
当点筋标注时，在左击确认时，增加剩余平行引线。
5，最后间距按全局比例设置。
如果按固定的1：100出图，文字与文字下划线设为100便可。但支持墙柱配筋大样和墙身配筋大样，必然得支持自动复合相应的比例间距。
主函数解析：
dimbar(ptlist dotflag)，ptlist为引线端点点表，由前述两函数获得，dotflag为点筋与否标识。
函数内的flag为动态退出标志；ang为文字角度(defun dimbar (ptlist dotflag / len pt str qline qtext box box-len tline flag ptr ptu-u ang pto1 pto2 pto pt-x pt-y i )
(setq flag t )
(setq ang 0)
;务必支持全局比例hnu:dimscale
(if (null hnu:dimscale)
(setq hnu:dimscale 100)
);if
(setq len (length ptlist))
(setq pt (car ptlist))；只处理一根引线作为动态。
(setup "symbol")；这句为设置图层，setup为一函数，以后提供
(if dotflag (setq str (strcat (itoa len) "%%13220")) (setq str "%%1328@200"));if 处理输入
(if (null dotflag) (make_insert pt "_ARCHTICK" (* 1.5 hnu:dimscale) pi (getvar "clayer")));if 处理线筋符号
(setq qline (make_line (list pt (setq ptu (offset_point pt hnu:dimscale 0 0))) (getvar "clayer") ));qline 斜引线，初始值，pt，与任意点
(setq qtext (make_text_b ptu ang (* 3.0 hnu:dimscale) 1 str (getvar "clayer"))) ;qtext 文字，高度与全局比例相关，对齐方式，中
(setq box (get_textbox qtext)
box-len (+hnu:dimscale (* 0.5 (distance (car box) (cadr box)))))
(setq tline (make_line (list ptu (setq pte (offset_point ptu box-len 0 0)))(getvar "clayer"))) ;tline 文字下划线，初始值随意
(prompt "\n确定文字位置，逆时针旋转R，顺时针旋转E，撤销U")
(while (and (setq ptr (grread t 15 2))
(not (and (= 2 (car ptr)); 键盘事件
(or (= 13 (cadr ptr)) (= 32 (cadr ptr))) ;_Enter Space
))
(not (or (= (car ptr) 11) (= (car ptr) 25)));_Mouse Right button
flag
)
; (redraw)
(cond ((= (car ptr) 3);_Mouse Left button
(setq ptu-u (cadr ptr))
(setq ptu-w (trans ptu-u 1 0))
(set-dxf qtext 11 ptu-w)
(set-dxf tline 10 (setq pto1 (offset_point ptu-w (- box-len) (- hnu:dimscale) ang)))
(set-dxf tline 11 (setq pto2 (offset_point ptu-w box-len (- hnu:dimscale) ang)))
(if (< (distance pt pto1) (distance pt pto2))(setq pto pto1)(setq pto pto2))
(set-dxf qline 11 pto)
;点筋加入引线
(if (<= len 4);一般点筋少于等于4进行如此标注。
(progn
(setq i 0)
(repeat (1- len)
(setq i (1+ i))
(setq pt-x (nth i ptlist) )
(setq pt-y (inters pt-x (offset_point pt-x 100 0 (angle (get-dxf 10 qline)(get-dxf 11 qline))) pto1 pto2 nil))
(make_line (list pt-x pt-y) (getvar "clayer"))
(if (< (distance pto1 pt-y)(distance pto2 pt-y))
(if (< (distance pto1 pto2)(distance pto2 pt-y));确保在点在外面
(set-dxf tline 10 pt-y)
)
(if (< (distance pto1 pto2)(distance pto1 pt-y));确保在点在外面
(set-dxf tline 11 pt-y)
)
)
);repeat
));if len
;点筋加入引线
(setq flag nil)
))
(cond ((= (car ptr) 5)
(setq ptu-u (cadr ptr)) ;很明显ptu-w为uCS下
(setq ptu-w (trans ptu-u 1 0));很明显ptu-w为wCS下
(set-dxf qtext 11 ptu-w) ;设置 qtext位置。
(set-dxf tline 10 (setq pto1 (offset_point ptu-w (- box-len) (- hnu:dimscale) ang)));修正文字下划线tline位置。
(set-dxf tline 11 (setq pto2 (offset_point ptu-w box-len (- hnu:dimscale) ang))) ;修正文字下划线tline位置
(if (<= (distance pt pto1) (distance pt pto2))(setq pto pto1)(setq pto pto2)) ;修正引线qline位置，其一端为文字下划线最近点
(set-dxf qline 11 pto)
))
(cond ((= (car ptr) 2);键盘事件
; (if (or (= (ascii "S") (cadr ptr)) (= (ascii "s") (cadr ptr))) (command "scale" ss "" pt 0.5))
; (if (or (= (ascii "A") (cadr ptr)) (= (ascii "a") (cadr ptr))) (command "scale" ss "" pt 2))
(if (or (= (ascii "R") (cadr ptr)) (= (ascii "r") (cadr ptr)))
(progn (command "rotate" qtext tline "" ptu-u 90) (setq ang (+ ang (* 0.5 pi)))
(setq pto1 (get-dxf 10 tline)
pto2 (get-dxf 11 tline))
(if (<= (distance pt pto1) (distance pt pto2))(setq pto pto1)(setq pto pto2)) ;修正引线qline位置，其一端为文字下划线最近点
(set-dxf qline 11 pto))
)
(if (or (= (ascii "E") (cadr ptr)) (= (ascii "e") (cadr ptr)))
(progn (command "rotate" qtext tline "" ptu-u -90) (setq ang (- ang (* 0.5 pi)))
(setq pto1 (get-dxf 10 tline)
pto2 (get-dxf 11 tline))
(if (<= (distance pt pto1) (distance pt pto2))(setq pto pto1)(setq pto pto2)) ;修正引线qline位置，其一端为文字下划线最近点
(set-dxf qline 11 pto))
)
; (if (or (= (ascii "E") (cadr ptr)) (= (ascii "e") (cadr ptr))) (command "rotate" ss "" pt -90))
(if (or (= (ascii "U") (cadr ptr)) (= (ascii "u") (cadr ptr)))
(progn
(entdel qtext)(entdel qline)(entdel tline)(setq flag nil))
) ;删除ss，同时退出循环。
))
);while
)主函数做的事情是，接收输入，生成文字，文字下划线，引线。然后动态调整其端点。
值得注意的是，1，get_textbox为我以前文章中的取文本四角点，offset_point为比polar更直观的求点自定义函数。2，make_text_b为，make_line自定义生成对象的函数，get-dxf，set-dxf为组码获得与更新。3，动态中，鼠标当前点，使用UCS，WCS系两点保存。
调用函数代码(defun C:dba( / ss ptlist )
;Designed by 林霄云 2014年4月20日
;dim bar 标注点钢筋与线钢筋
(setq ss (ssget '((0 . "INSERT,*LINE")))) ;最好加上钢筋图层控制
(if ss
(progn
(setq ptlist (get_bar_ptlist ss)) ;有点筋么？
(if ptlist
(progn
(dimbar ptlist t )
);progn
(progn
(setq pt (get_linebar_pt ss)) ;有线筋么？
(if pt
(dimbar (list pt) nil )
)
);progn
);if
));if ss
(princ)
);defun
还是得强调钱处理函数，代码给上，处理点筋点表(defun get_bar_ptlist( ss / pt_list pt en ent ptli )
;函数get_bar_ptlist，参数ss 选择集。返回值，点筋点表。
;Desiged by 林霄云 2014年2月10日
;(setq ss (ssget '((0 . "INSERT,LWPOLYLINE"))));由用户任意选择TEXT实体 用于测试
(setq pt_list nil)
(foreach en (SS2ENLIST ss)
(setq ent (entget en))
(setq typ (get-dxf 0 en))
(cond
((= typ "INSERT")
(if (= (get-dxf 2 en) "点筋") (setq pt (get-dxf 10 en)) (setq pt nil));if ;块插入点，WCS
)
((= typ "LWPOLYLINE")
;如果是点筋，取中点
(if (and (= (get-dxf 90 en) 2)
(= (abs(get-dxf 42 en)) 1))
(setq pt (mid_point (car (setq ptli (get_pline_vertex en))) (cadr ptli)))
(setq pt nil)
);if
)
);cond
(if pt
(setq pt_list (cons pt pt_list))
)
);foreach
(reverse pt_list)
)比较难搞的线筋点表，敢情是最原创的东西，使用ssnamex函数。(defun get_linebar_pt( ss / pt sslist )
;Designed by 林霄云 2014年4月20日
;取线筋接触点。多选时，仅支持取第一根
;(setq ss (ssget '((0 . "INSERT,LWPOLYLINE"))))
(setq sslist (ssnamex ss 0))
(cond((= (caar sslist) 1)(setq pt (cadr (last (car sslist)))))
((or (= (caar sslist) 2)(= (caar sslist) 3)) (setq pt (mid_point (last(cadr (last sslist))) (last (cadddr (last sslist)))))
;(command "line" "non" (last(cadr (last sslist))) "non" (last(caddr (last sslist))) "non" (last(cadddr (last sslist))) "non" (last(last(last sslist)))"c") ;测试代码
)
);cond
;如果是线筋，取最近点
(setq pt (vlax-curve-getClosestPointTo (vlax-ename->vla-object (ssname ss 0)) pt t));pt均为WCS下。
;(command "line" "non" (list 0 0) "non" (trans pt 0 1) "")
)鉴于代码中预留的解析比较详细，就不赘言了。所有的思路与步骤都已经给上。
结果
详测试图。
结论
基本完美的实现了，动态的，支持UCS的，智能判断的（文字处理，不提供输入，二是进行默认处理，是我自己的见解）点筋线筋标注集成命令。
（本文是我原创的最后一个功能，以后可能不做了，但已有的未发表的，将择机择日发布，附件中是还待整理的通用函数）
预告
1，墙线绘制源码解析（支持UCS，偏心或居中布置，厚度设置，自动填充）
2，梁线绘制源码解析（支持偏心或居中布置，宽度设置，梁线十字裁剪，梁截面标注，生成梁中轴线）
根据两点原则，1、不过度设计，避免多余错误。2、不过多操作。
基于此，我不断的看自己作品的演示图，以期有更合适的操作，更清晰的概念。
对于引线是多引线还是单引线，原文为;点筋加入引线
(if (<= len 4);一般点筋少于等于4进行如此标注。现修改为;点筋加入引线
(if (> len 1);得到更清晰的效果是，左击，便是多引线。其他情况，为单引线。更为清晰。于是，提示改为 (prompt "\n确定文字位置，逆时针旋转R，顺时针旋转E，撤销U，左击为多引线") 辛苦了，写这么一大篇，只是隔行与隔山，完全看不懂。 版主我加载了，不知道命令是什么？怎么用呀 虽然不懂，但也要强烈支持 非常有用，感谢楼主的无私精神 不错！
最好提供一个dwg测试文件 xyp1964 发表于 2014-4-23 10:36 static/image/common/back.gif
不错！
最好提供一个dwg测试文件
可以不要的
非常有用，感谢楼主的无私精神,期待墙线的源码放出！ (if (null dotflag) (make_insert pt "_ARCHTICK" (* 1.5 hnu:dimscale) pi (getvar "clayer")));if 处理线筋符号在后面的撤销过程中，亦应有相应的删除操作。(if (null dotflag) (entdel (ssname (ssget (trans pt 0 1) '((0 . "INSERT")(2 . "_ARCHTICK"))) 0)));pt "_ARCHTICK" ;ssget ucs坐标系的点，处理第一个。 林兄很给力啊。