明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 4396|回复: 26

[源码] 管线标注程序改版

[复制链接]
发表于 2016-4-19 16:44 | 显示全部楼层 |阅读模式
管线标注已经有各位大神写过,我写这个只是根据个人需求对原程序进行调整,要谢就谢开心长老吧。
开心长老的原帖地址http://bbs.mjtd.com/forum.php?mo ... &fromuid=253837
改造如下:
1.点选直线或者多段线,自动判断前点后点,求出两点间距离。
2.有时候自动标注出来的字会与其他字重叠,故改造成手动选择标注位置。
  1. (VL-LOAD-COM)
  2. (defun c:GXBZ (/ fz Write_Dcl gj pd zg DCL_ID ent obj pt1 pt2 dst a1 str gr
  3.                  tObj
  4.               )
  5.   (setvar "CMDECHO" 0)
  6.   (defun fz ()
  7.     (setq gj (GET_tile "gj"))
  8.     (setq pd (GET_TILE "pd"))
  9.     (setq zg (atof (GET_TILE "zg")))
  10.   )  ;;;临时生成Dcl文件 返回文件名
  11.   (defun Write_Dcl (/ Dcl_File file str)
  12.     (setq Dcl_File (vl-filename-mktemp nil nil ".Dcl"))
  13.     (setq file (open Dcl_File "W"))
  14.     (foreach str '("RECT:dialog" "{label="管道标注";"
  15.        ":edit_box {key="gj";label="管径:";value="DN300";}"
  16.        ":edit_box {key="pd";label="坡度:";value="2.0%";}"
  17.        ":edit_box {key="zg";label="字高:";value="2.5";}" "ok_only;}"
  18.       )
  19.       (write-line str file)
  20.     )
  21.     (close file)
  22.     Dcl_File
  23.   )
  24.   (SETQ DCL_ID (LOAD_DIALOG (setq Dcl_File (Write_Dcl))))
  25.   (vl-file-delete Dcl_File)
  26.   (NEW_DIALOG "RECT" DCL_ID)
  27.   (ACTION_TILE "accept" "(fz) (DONE_DIALOG)")
  28.   (START_DIALOG)
  29.   (UNLOAD_DIALOG DCL_ID)
  30.   (while (setq ent (entsel "\n 选择直线或多段线:"))
  31.     (setq p (cadr ent);所击点
  32.           ent (car ent);所击线条
  33.           obj (vlax-ename->vla-object ent)
  34.           objname (vla-get-ObjectName obj)
  35.     )
  36.     (cond
  37.       ((wcmatch ObjName "*Polyline")
  38.         (setq pp (vlax-curve-getclosestpointto obj (trans p 1 0));所击点最近的位置
  39.               n (fix (vlax-curve-getparamatpoint obj pp));所击点在第几段
  40.               pt1 (vlax-curve-getPointAtParam obj n);前点位置
  41.               pt2 (vlax-curve-getPointAtParam obj (1+ n));后点位置
  42.               dst (- (vlax-curve-getDistAtPoint obj pt2)
  43.                      (vlax-curve-getDistAtPoint obj pt1)
  44.                   );距离
  45.               str (strcat gj " L=" (rtos dst 2 1) "m i=" pd);字符串

  46.         )
  47.         (setq a1 (angle pp (mapcar
  48.                              '+
  49.                              pp
  50.                              (vlax-curve-getfirstderiv obj
  51.                                                        (vlax-curve-getparamatpoint obj pp)
  52.                              )
  53.                            )
  54.                  )
  55.         );切线角度
  56.         (if (> (car pt1) (car pt2))
  57.           (setq a1 (+ a1 pi))
  58.         )
  59.       )
  60.       ((wcmatch ObjName "AcDbLine")
  61.         (setq pp (vlax-curve-getclosestpointto obj (trans p 1 0));所击点最近的位置
  62.               pt1 (vlax-curve-getStartPoint obj);起点
  63.               pt2 (vlax-curve-getEndPoint obj);终点
  64.               dst (vla-get-Length obj);距离
  65.               str (strcat gj " L=" (rtos dst 2 1) "m i=" pd);字符串

  66.         )
  67.         (setq a1 (angle pt1 pt2))
  68.         (if (> (car pt1) (car pt2))
  69.           (setq a1 (+ a1 pi))
  70.         )
  71.       )
  72.       (t
  73.         (princ "\n 不支持的类型。")
  74.         (setq str nil)
  75.       )
  76.     );cond
  77.     (if (and
  78.           str
  79.           pp
  80.           zg
  81.           a1
  82.         )
  83.       (progn
  84.         (setq tObj (vlax-ename->vla-object (entmakex (list '(0 . "TEXT")
  85.                                                            (cons 1 str)
  86.                                                            (cons 8 "DM-管线标注")
  87.                                                            (cons 10 pp)
  88.                                                            (cons 40 zg)
  89.                                                            (cons 50 a1) '
  90.                                                            (71 . 0) '
  91.                                                            (72 . 4)
  92.                                                            (cons 11 pp) '
  93.                                                            (73 . 2)
  94.                                                      )
  95.                                            )
  96.                    )
  97.         )
  98.         (while (and
  99.                  tObj
  100.                  (setq gr (grread 't 5 0))
  101.                  (not (eq 3 (car gr)))
  102.                );只要不点击左键,一直循环
  103.           (cond
  104.             ((eq 5 (car gr))
  105.               (vla-put-TextAlignmentPoint tObj (vlax-3D-point
  106.                                                               (trans
  107.                                                                      (cadr gr)
  108.                                                                      1 0
  109.                                                               )
  110.                                                )
  111.               )
  112.             )
  113.             (t
  114.               nil
  115.             )
  116.           )
  117.         );while
  118.       )
  119.     )
  120.   );while
  121.   (princ)
  122. )
"觉得好,就打赏"
还没有人打赏,支持一下
 楼主| 发表于 2016-4-19 16:51 | 显示全部楼层
按照惯例,还是应该发个截图~~~

本帖子中包含更多资源

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

x

评分

参与人数 1明经币 +1 收起 理由
USER2128 + 1 赞一个!

查看全部评分

回复 支持 1 反对 0

使用道具 举报

发表于 2019-5-12 16:45 | 显示全部楼层
alpha223334 发表于 2018-7-19 07:50
感谢 77077 !感谢guangdonglbq!根据你们的的程序修改到我需要的管线标注了,花了不少时间,大家帮忙验证

命令: GXBZ hztxt.shx 是常规字体,不是大字体。0
0.800000
*取消*

加载以后,命令行出现上述情况,怎么解决???
发表于 2019-5-23 18:08 | 显示全部楼层
alpha223334 发表于 2018-7-19 07:50
感谢 77077 !感谢guangdonglbq!根据你们的的程序修改到我需要的管线标注了,花了不少时间,大家帮忙验证

单个能不能是可以自由移动标注的,就是那种沿着线移动的
发表于 2016-4-20 00:13 | 显示全部楼层
GOOD,修改了一下,可以不显示坡度了
  1. (VL-LOAD-COM)
  2. (defun c:GXBZ (/ fz Write_Dcl gj pd zg DCL_ID ent obj pt1 pt2 dst a1 str gr
  3.                                                                 tObj
  4.               )
  5.   (setvar "CMDECHO" 0)
  6.   (defun fz ()
  7.     (setq gj (GET_tile "gj"))
  8.     (setq pd (GET_TILE "pd"))
  9.     (setq zg (atof (GET_TILE "zg")))
  10.   )  ;;;临时生成Dcl文件 返回文件名
  11.   (defun Write_Dcl (/ Dcl_File file str)
  12.     (setq Dcl_File (vl-filename-mktemp nil nil ".Dcl"))
  13.     (setq file (open Dcl_File "W"))
  14.     (foreach str '("RECT:dialog" "{label=\"管道标注\";"
  15.                                                                                 ":edit_box {key=\"gj\";label=\"管径:\";value=\"DN300\";}"
  16.                                                                                 ":edit_box {key=\"pd\";label=\"坡度:\";value=\"2.0%\";}"
  17.                                                                                 ":edit_box {key=\"zg\";label=\"字高:\";value=\"2.5\";}" "ok_only;}"
  18.                                                                         )
  19.       (write-line str file)
  20.     )
  21.     (close file)
  22.     Dcl_File
  23.   )
  24.   (SETQ DCL_ID (LOAD_DIALOG (setq Dcl_File (Write_Dcl))))
  25.   (vl-file-delete Dcl_File)
  26.   (NEW_DIALOG "RECT" DCL_ID)
  27.   (ACTION_TILE "accept" "(fz) (DONE_DIALOG)")
  28.   (START_DIALOG)
  29.   (UNLOAD_DIALOG DCL_ID)
  30.   (while (setq ent (entsel "\n 选择直线或多段线:"))
  31.     (setq p (cadr ent);所击点
  32.                         ent (car ent);所击线条
  33.                         obj (vlax-ename->vla-object ent)
  34.                         objname (vla-get-ObjectName obj)
  35.     )
  36.     (cond
  37.       ((wcmatch ObjName "*Polyline")
  38.         (setq pp (vlax-curve-getclosestpointto obj (trans p 1 0));所击点最近的位置
  39.                                         n (fix (vlax-curve-getparamatpoint obj pp));所击点在第几段
  40.                                         pt1 (vlax-curve-getPointAtParam obj n);前点位置
  41.                                         pt2 (vlax-curve-getPointAtParam obj (1+ n));后点位置
  42.                                         dst (- (vlax-curve-getDistAtPoint obj pt2)
  43.                                                                 (vlax-curve-getDistAtPoint obj pt1)
  44.                                                         );距离
  45.                                         str (strcat gj " L=" (rtos dst 2 1) "m" (if(/= pd "") (strcat " i=" pd) ""));字符串
  46.         )
  47.         (setq a1 (angle pp (mapcar
  48.                              '+
  49.                              pp
  50.                              (vlax-curve-getfirstderiv obj
  51.                                                                                                                          (vlax-curve-getparamatpoint obj pp)
  52.                              )
  53.                            )
  54.                  )
  55.         );切线角度
  56.         (if (> (car pt1) (car pt2))
  57.           (setq a1 (+ a1 pi))
  58.         )
  59.       )
  60.       ((wcmatch ObjName "AcDbLine")
  61.         (setq pp (vlax-curve-getclosestpointto obj (trans p 1 0));所击点最近的位置
  62.                                         pt1 (vlax-curve-getStartPoint obj);起点
  63.                                         pt2 (vlax-curve-getEndPoint obj);终点
  64.                                         dst (vla-get-Length obj);距离
  65.                                         str (strcat gj " L=" (rtos dst 2 1) "m" (if(/= pd "") (strcat " i=" pd) ""));字符串
  66.         )
  67.         (setq a1 (angle pt1 pt2))
  68.         (if (> (car pt1) (car pt2))
  69.           (setq a1 (+ a1 pi))
  70.         )
  71.       )
  72.       (t
  73.         (princ "\n 不支持的类型。")
  74.         (setq str nil)
  75.       )
  76.     );cond
  77.     (if (and
  78.           str
  79.           pp
  80.           zg
  81.           a1
  82.         )
  83.       (progn
  84.         (setq tObj (vlax-ename->vla-object (entmakex (list '(0 . "TEXT")
  85.                                                                                                                                                                                                                          (cons 1 str)
  86.                                                                                                                                                                                                                          (cons 8 "DM-管线标注")
  87.                                                                                                                                                                                                                          (cons 10 pp)
  88.                                                                                                                                                                                                                          (cons 40 zg)
  89.                                                                                                                                                                                                                          (cons 50 a1) '
  90.                                                                                                                                                                                                                          (71 . 0) '
  91.                                                                                                                                                                                                                          (72 . 4)
  92.                                                                                                                                                                                                                          (cons 11 pp) '
  93.                                                                                                                                                                                                                          (73 . 2)
  94.                                                      )
  95.                                            )
  96.                    )
  97.         )
  98.         (while (and
  99.                  tObj
  100.                  (setq gr (grread 't 5 0))
  101.                  (not (eq 3 (car gr)))
  102.                );只要不点击左键,一直循环
  103.           (cond
  104.             ((eq 5 (car gr))
  105.               (vla-put-TextAlignmentPoint tObj (vlax-3D-point
  106.                                                                                                                                                                                                  (trans
  107.                                                                                                                                                                                                          (cadr gr)
  108.                                                                                                                                                                                                          1 0
  109.                                                                                                                                                                                                  )
  110.                                                )
  111.               )
  112.             )
  113.             (t
  114.               nil
  115.             )
  116.           )
  117.         );while
  118.       )
  119.     )
  120.   );while
  121.   (princ)
  122. )
发表于 2016-4-20 08:16 | 显示全部楼层
程序不错,有实用价值
发表于 2016-4-20 10:56 | 显示全部楼层
本帖最后由 l18c19 于 2016-4-20 16:46 编辑

1、3楼的程序都值得下载学习!

向1、3楼请教,修改什么地方能将L=.?m后面的?由保留1位小数,变成保留3位(???)小数。谢谢!
发表于 2016-5-11 14:47 | 显示全部楼层
显示单位不准的
发表于 2018-7-17 07:53 | 显示全部楼层
@77077 楼主,我想问下您修改的程序能不能改成把位置固定在线中的位置啊
发表于 2018-7-18 14:17 | 显示全部楼层
参考我的帖子:
http://bbs.mjtd.com/thread-176541-1-1.html
画线的时候即标注,不是更省事吗?
发表于 2018-7-19 07:50 | 显示全部楼层
感谢 77077 !感谢guangdonglbq!根据你们的的程序修改到我需要的管线标注了,花了不少时间,大家帮忙验证

本帖子中包含更多资源

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

x

点评

实验不能运行怎么?  发表于 2019-7-4 06:53

评分

参与人数 1明经币 +1 收起 理由
sclp2008 + 1 很给力!

查看全部评分

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-28 16:07 , Processed in 0.239412 second(s), 32 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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