设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 引线标注点筋与线筋源码解析（支持UCS）
1234567下一页
返回列表 发新帖
查看: 16855|回复: 62

[源码] 引线标注点筋与线筋源码解析（支持UCS）

    [复制链接]
林霄云
发表于 2014-4-22 23:48 | 显示全部楼层 |阅读模式
本帖最后由 林霄云 于 2014-4-23 22:09 编辑

引线标注点筋与线筋源码解析（支持UCS）
我曾说，我会离开lisp。谁又知道我从软件工程转土木工程有多难，又知道我内心有燃烧过那热火。——记录与真实生活
闲话少说，看正文。
思路
将标注点筋和线筋（一个标根数一个是标间距）集成在一起。应该做如下几件事：
1，选择后的选择集，自动判断是标注点筋还是线筋。
如果有点筋，标注点筋，如果没有点筋，标注线筋。
2，引线自动生成。
对于点筋，取点筋中点，如果是块，该是插入点，作为引线一端。对于线筋，取选择框中点距对象最近的点。且各自成前处理函数，生成点表。
取点筋点表
  2. (defun get_bar_ptlist( ss / pt_list pt en ent ptli )
  3. ;函数get_bar_ptlist，参数ss 选择集。返回值，点筋点表。
  4. ;Desiged by 林霄云 2014年2月10日
取线筋点表
  2. (defun get_linebar_pt( ss / pt sslist )
  3. ;Designed by 林霄云 2014年4月20日
  4. ;取线筋接触点。多选时，仅支持取第一根
3，动态处理文字位置，且为当前UCS下，支持90度旋转
对文字及文字下划线，拖动模式，更新其坐标点。旋转时，亦更新相应坐标点。
4，支持平行引线
当点筋标注时，在左击确认时，增加剩余平行引线。
5，最后间距按全局比例设置。
如果按固定的1：100出图，文字与文字下划线设为100便可。但支持墙柱配筋大样和墙身配筋大样，必然得支持自动复合相应的比例间距。
主函数解析：
dimbar(ptlist dotflag)，ptlist为引线端点点表，由前述两函数获得，dotflag为点筋与否标识。
函数内的flag为动态退出标志；ang为文字角度
  2. (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 )
  3. (setq flag t )
  4. (setq ang 0)

  6. ;务必支持全局比例hnu:dimscale
  7. (if (null hnu:dimscale)
  8. (setq hnu:dimscale 100)
  9. );if

  11. (setq len (length ptlist))
  12. (setq pt (car ptlist))；只处理一根引线作为动态。
  13. (setup "symbol")；这句为设置图层，setup为一函数，以后提供

  15. (if dotflag (setq str (strcat (itoa len) "%%13220")) (setq str "%%1328@200"));if 处理输入
  16. (if (null dotflag) (make_insert pt "_ARCHTICK" (* 1.5 hnu:dimscale) pi (getvar "clayer")));if 处理线筋符号
  17.   

  19. (setq qline (make_line (list pt (setq ptu (offset_point pt hnu:dimscale 0 0))) (getvar "clayer") ))  ;qline 斜引线，初始值，pt，与任意点
  20. (setq qtext (make_text_b ptu ang (* 3.0 hnu:dimscale) 1 str (getvar "clayer")))            ;qtext 文字，高度与全局比例相关，对齐方式，中
  21. (setq box (get_textbox qtext)
  22.      box-len (+  hnu:dimscale (* 0.5 (distance (car box) (cadr box)))))
  23.   
  24. (setq tline (make_line (list ptu (setq pte (offset_point ptu box-len 0 0)))(getvar "clayer")))       ;tline 文字下划线，初始值随意

  26. (prompt "\n确定文字位置，逆时针旋转R，顺时针旋转E，撤销U")

  28.       (while (and (setq ptr (grread t 15 2))
  29.               (not (and (= 2 (car ptr)); 键盘事件
  30.                     (or (= 13 (cadr ptr)) (= 32 (cadr ptr))) ;_Enter Space
  31.             ))
  32.              (not (or (= (car ptr) 11) (= (car ptr) 25)));_Mouse Right button
  33.            flag
  34.                           )   
  35.                  ; (redraw)
  36.       (cond ((= (car ptr) 3);_Mouse Left button
  37.           (setq ptu-u (cadr ptr))
  38.           (setq ptu-w (trans ptu-u 1 0))
  39.           (set-dxf qtext 11 ptu-w)
  40.           (set-dxf tline 10 (setq pto1 (offset_point ptu-w (- box-len) (- hnu:dimscale) ang)))
  41.           (set-dxf tline 11 (setq pto2 (offset_point ptu-w box-len (- hnu:dimscale) ang)))
  42.           (if (< (distance pt pto1) (distance pt pto2))(setq pto pto1)(setq pto pto2))
  43.           (set-dxf qline 11 pto)
  44.           ;点筋加入引线
  45.           (if (<= len 4);一般点筋少于等于4进行如此标注。
  46.           (progn
  47.           (setq i 0)
  48.           (repeat (1- len)
  49.           (setq i (1+ i))
  50.           (setq pt-x (nth i ptlist) )
  51.           (setq pt-y (inters pt-x (offset_point pt-x 100 0 (angle (get-dxf 10 qline)(get-dxf 11 qline))) pto1 pto2 nil))
  52.           (make_line (list pt-x pt-y) (getvar "clayer"))
  53.           (if (< (distance pto1 pt-y)(distance pto2 pt-y))
  54.           (if (< (distance pto1 pto2)(distance pto2 pt-y));确保在点在外面
  55.           (set-dxf tline 10 pt-y)
  56.           )
  57.           (if (< (distance pto1 pto2)(distance pto1 pt-y));确保在点在外面
  58.           (set-dxf tline 11 pt-y)
  59.           )
  60.           )
  61.           );repeat
  62.           ));if len
  63.           ;点筋加入引线
  64.           (setq flag nil)
  65.            ))
  66.       (cond ((= (car ptr) 5)
  67.           (setq ptu-u (cadr ptr))      ;很明显ptu-w为uCS下
  68.           (setq ptu-w (trans ptu-u 1 0))  ;很明显ptu-w为wCS下
  69.               
  70.           (set-dxf qtext 11 ptu-w)                           ;设置 qtext位置。
  71.           (set-dxf tline 10 (setq pto1 (offset_point ptu-w (- box-len) (- hnu:dimscale) ang)))  ;修正文字下划线tline位置。
  72.           (set-dxf tline 11 (setq pto2 (offset_point ptu-w box-len (- hnu:dimscale) ang)))    ;修正文字下划线tline位置
  73.           (if (<= (distance pt pto1) (distance pt pto2))(setq pto pto1)(setq pto pto2))      ;修正引线qline位置，其一端为文字下划线最近点
  74.           (set-dxf qline 11 pto)      
  75.           ))
  76.         (cond ((= (car ptr) 2);键盘事件
  77.          ; (if (or (= (ascii "S") (cadr ptr)) (= (ascii "s") (cadr ptr))) (command "scale" ss "" pt 0.5))
  78.          ; (if (or (= (ascii "A") (cadr ptr)) (= (ascii "a") (cadr ptr))) (command "scale" ss "" pt 2))
  79.           (if (or (= (ascii "R") (cadr ptr)) (= (ascii "r") (cadr ptr)))
  80.           (progn (command "rotate" qtext tline "" ptu-u 90) (setq ang (+ ang (* 0.5 pi)))
  81.           (setq pto1 (get-dxf 10 tline)
  82.             pto2 (get-dxf 11 tline))
  83.           (if (<= (distance pt pto1) (distance pt pto2))(setq pto pto1)(setq pto pto2))    ;修正引线qline位置，其一端为文字下划线最近点
  84.           (set-dxf qline 11 pto))
  85.           )
  86.           (if (or (= (ascii "E") (cadr ptr)) (= (ascii "e") (cadr ptr)))
  87.           (progn (command "rotate" qtext tline "" ptu-u -90) (setq ang (- ang (* 0.5 pi)))   
  88.           (setq pto1 (get-dxf 10 tline)
  89.             pto2 (get-dxf 11 tline))
  90.           (if (<= (distance pt pto1) (distance pt pto2))(setq pto pto1)(setq pto pto2))    ;修正引线qline位置，其一端为文字下划线最近点
  91.           (set-dxf qline 11 pto))
  92.           )
  93.          ; (if (or (= (ascii "E") (cadr ptr)) (= (ascii "e") (cadr ptr))) (command "rotate" ss "" pt -90))
  94.           (if (or (= (ascii "U") (cadr ptr)) (= (ascii "u") (cadr ptr)))
  95.           (progn
  96.           (entdel qtext)(entdel qline)(entdel tline)  (setq flag nil))
  97.           ) ;删除ss，同时退出循环。
  98.             ))
  99.            );while

  101. )
主函数做的事情是，接收输入，生成文字，文字下划线，引线。然后动态调整其端点。
值得注意的是，1，get_textbox为我以前文章中的取文本四角点，offset_point为比polar更直观的求点自定义函数。2，make_text_b为，make_line自定义生成对象的函数，get-dxf，set-dxf为组码获得与更新。3，动态中，鼠标当前点，使用UCS，WCS系两点保存。
调用函数代码
  2. (defun C:dba( / ss ptlist )
  3. ;Designed by 林霄云 2014年4月20日
  4. ;dim bar 标注点钢筋与线钢筋

  6. (setq ss (ssget '((0 . "INSERT,*LINE")))) ;最好加上钢筋图层控制
  7. (if ss
  8. (progn
  9. (setq ptlist (get_bar_ptlist ss))       ;有点筋么？
  10. (if ptlist
  11. (progn
  12. (dimbar ptlist t )
  13. );progn
  14. (progn
  15. (setq pt (get_linebar_pt ss))      ;有线筋么？
  16. (if pt
  17. (dimbar (list pt) nil )
  18. )
  19. );progn
  20. );if

  22. ));if ss

  24. (princ)
  25. );defun
还是得强调钱处理函数，代码给上，处理点筋点表
  2. (defun get_bar_ptlist( ss / pt_list pt en ent ptli )
  3. ;函数get_bar_ptlist，参数ss 选择集。返回值，点筋点表。
  4. ;Desiged by 林霄云 2014年2月10日
  5. ;(setq ss (ssget '((0 . "INSERT,LWPOLYLINE"))));由用户任意选择TEXT实体 用于测试
  6. (setq pt_list nil)
  7. (foreach en (SS2ENLIST ss)
  8. (setq ent (entget en))
  9. (setq typ (get-dxf 0 en))
  10. (cond
  11. ((= typ "INSERT")
  12. (if (= (get-dxf 2 en) "点筋") (setq pt (get-dxf 10 en)) (setq pt nil));if ;块插入点，WCS
  13. )
  14. ((= typ "LWPOLYLINE")

  16. ;如果是点筋，取中点
  17. (if (and (= (get-dxf 90 en) 2)
  18.      (= (abs(get-dxf 42 en)) 1))  
  19. (setq pt (mid_point (car (setq ptli (get_pline_vertex en))) (cadr ptli)))
  20. (setq pt nil)
  21. );if
  22. )
  23. );cond
  24. (if pt
  25. (setq pt_list (cons pt pt_list))
  26. )
  27. );foreach
  28. (reverse pt_list)
  29. )
比较难搞的线筋点表，敢情是最原创的东西，使用ssnamex函数。
  2. (defun get_linebar_pt( ss / pt sslist )
  3. ;Designed by 林霄云 2014年4月20日
  4. ;取线筋接触点。多选时，仅支持取第一根
  5. ;(setq ss (ssget '((0 . "INSERT,LWPOLYLINE"))))

  7. (setq sslist (ssnamex ss 0))
  8. (cond  ((= (caar sslist) 1)(setq pt (cadr (last (car sslist)))))
  9.      ((or (= (caar sslist) 2)  (= (caar sslist) 3)) (setq pt (mid_point (last(cadr (last sslist))) (last (cadddr (last sslist)))))
  10.      ;(command "line" "non" (last(cadr (last sslist))) "non" (last(caddr (last sslist))) "non" (last(cadddr (last sslist))) "non" (last(last(last sslist)))  "c") ;测试代码
  11.      )
  12. );cond
  13. ;如果是线筋，取最近点
  14. (setq pt (vlax-curve-getClosestPointTo (vlax-ename->vla-object (ssname ss 0)) pt t))  ;pt均为WCS下。
  15. ;(command "line" "non" (list 0 0) "non" (trans pt 0 1) "")
  16. )
鉴于代码中预留的解析比较详细，就不赘言了。所有的思路与步骤都已经给上。
结果
详测试图。
结论
基本完美的实现了，动态的，支持UCS的，智能判断的（文字处理，不提供输入，二是进行默认处理，是我自己的见解）点筋线筋标注集成命令。
（本文是我原创的最后一个功能，以后可能不做了，但已有的未发表的，将择机择日发布，附件中是还待整理的通用函数）
预告
1，墙线绘制源码解析（支持UCS，偏心或居中布置，厚度设置，自动填充）
2，梁线绘制源码解析（支持偏心或居中布置，宽度设置，梁线十字裁剪，梁截面标注，生成梁中轴线）
点筋, 线筋, 引线标注, ssnamex, 林霄云

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x

评分

参与人数 3明经币 +6 金钱 +21 收起 理由
langjs + 2 + 21 很厉害哦，虽然用不到，绝对好东西。
xyp1964 + 3 赞一个!
lucas_3333 + 1 辛苦了，写这么一大篇，只是隔行与隔山，完.

查看全部评分

"觉得好，就打赏"
打赏
还没有人打赏，支持一下

相关帖子
回复

使用道具 举报

林霄云
 楼主| 发表于 2014-4-23 13:29 | 显示全部楼层
根据两点原则，1、不过度设计，避免多余错误。2、不过多操作。
基于此，我不断的看自己作品的演示图，以期有更合适的操作，更清晰的概念。
对于引线是多引线还是单引线，原文为
  1. ;点筋加入引线
  2.           (if (<= len 4);一般点筋少于等于4进行如此标注。
复制代码
现修改为
  1. ;点筋加入引线
  2.           (if (> len 1);
复制代码
得到更清晰的效果是，左击，便是多引线。其他情况，为单引线。更为清晰。于是，提示改为
  1. (prompt "\n确定文字位置，逆时针旋转R，顺时针旋转E，撤销U，左击为多引线")
复制代码
回复 支持 1 反对 0

使用道具 举报

lucas_3333
发表于 2014-4-23 00:30 | 显示全部楼层
辛苦了，写这么一大篇，只是隔行与隔山，完全看不懂。

点评

林霄云
相信你自己，会有一天看懂的。我写的是考虑了较多方面的因素了（但不是全部），所以参杂一起，像极了一道综合题  发表于 2014-4-23 10:50

评分

参与人数 1明经币 +1 收起 理由
林霄云 + 1 慢慢来

查看全部评分

回复 支持 1 反对 0

使用道具 举报

↘觉醒
发表于 2016-5-3 21:53 | 显示全部楼层
版主我加载了，不知道命令是什么？怎么用呀
回复 支持 0 反对 1

使用道具 举报

树櫴希德
发表于 2014-4-23 09:59 | 显示全部楼层
虽然不懂，但也要强烈支持
回复 支持 反对

使用道具 举报

firstinti
发表于 2014-4-23 10:10 | 显示全部楼层
非常有用，感谢楼主的无私精神
回复 支持 反对

使用道具 举报

xyp1964
发表于 2014-4-23 10:36 | 显示全部楼层
不错！
最好提供一个dwg测试文件
回复 支持 反对

使用道具 举报

林霄云
 楼主| 发表于 2014-4-23 10:47 | 显示全部楼层
xyp1964 发表于 2014-4-23 10:36
不错！
最好提供一个dwg测试文件

可以不要的

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x
回复 支持 反对

使用道具 举报

enn09
发表于 2014-4-23 10:51 | 显示全部楼层
非常有用，感谢楼主的无私精神,期待墙线的源码放出！
回复 支持 反对

使用道具 举报

林霄云
 楼主| 发表于 2014-4-23 11:12 | 显示全部楼层
  1. (if (null dotflag) (make_insert pt "_ARCHTICK" (* 1.5 hnu:dimscale) pi (getvar "clayer")));if 处理线筋符号
复制代码
在后面的撤销过程中，亦应有相应的删除操作。
  1. (if (null dotflag) (entdel (ssname (ssget (trans pt 0 1) '((0 . "INSERT")(2 . "_ARCHTICK"))) 0)));pt "_ARCHTICK" ;ssget ucs坐标系的点，处理第一个。
复制代码

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x
回复 支持 反对

使用道具 举报

机械工程师
发表于 2014-4-23 13:15 | 显示全部楼层
林兄很给力啊。
回复 支持 反对

使用道具 举报

1234567下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-4-20 09:42 , Processed in 0.285652 second(s), 31 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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