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

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

  69.         )
  70.         (setq a1 (angle pt1 pt2))
  71.         (if (> (car pt1) (car pt2))
  72.           (setq a1 (+ a1 pi))
  73.         )
  74.       )
  75.       (t
  76.         (princ "\n 不支持的类型。")
  77.         (setq str nil)
  78.       )
  79.     );cond
  80.     (if (and
  81.           str
  82.           pp
  83.           zg
  84.           a1
  85.         )
  86.       (progn
  87.         (setq tObj (vlax-ename->vla-object (entmakex (list '(0 . "TEXT")
  88.                                                            (cons 1 str)
  89.                                                            (cons 8 "DM-管线标注")
  90.                                                            (cons 10 pp)
  91.                                                            (cons 40 zg)
  92.                                                            (cons 50 a1) '
  93.                                                            (71 . 0) '
  94.                                                            (72 . 4)
  95.                                                            (cons 11 pp) '
  96.                                                            (73 . 2)
  97.                                                      )
  98.                                            )
  99.                    )
  100.         )
  101.         (while (and
  102.                  tObj
  103.                  (setq gr (grread 't 5 0))
  104.                  (not (eq 3 (car gr)))
  105.                );只要不点击左键，一直循环
  106.           (cond
  107.             ((eq 5 (car gr))
  108.               (vla-put-TextAlignmentPoint tObj (vlax-3D-point
  109.                                                               (trans
  110.                                                                      (cadr gr)
  111.                                                                      1 0
  112.                                                               )
  113.                                                )
  114.               )
  115.             )
  116.             (t
  117.               nil
  118.             )
  119.           )
  120.         );while
  121.       )
  122.     )
  123.   );while
  124.   (princ)
  125. )


网友答:
shcvip 发表于 2023-10-26 13:12
如何记住上一次的管径呢，在下一次执行的时候？

  (defun fz ()
                (setq %%$$GJstr (GET_TILE "gj"))
                (setq %%$$PDJstr (GET_TILE "pd"))
                (setq %%$$zgstr (GET_TILE "zg"))
    (setq %%$$zg (* 3.5(atof %%$$zgstr)));;取得比例
  )  ;;;临时生成Dcl文件 返回文件名
  (defun Write_Dcl (/ Dcl_File file str)
    (setq Dcl_File (vl-filename-mktemp nil nil ".Dcl"))
    (setq file (open Dcl_File "W"))
    (foreach str (list
                                                                         "RECT:dialog"
                                                                         "{label=\"管线标注\";"
                                                                                ":edit_box {key=\"gj\";"
                                                                                "label=\"管线规格：\";"
                                                                         (strcat "value=" "\"" %%$$GJstr "\"" ";")
                                                                                "}"
                                                                                ":edit_box {key=\"pd\";"
                                                                                "label=\"管线坡度：\";"
                                                                          (strcat "value=" "\"" %%$$PDJstr "\"" ";")
                                                                                "}"
                                                                                ":edit_box {key=\"zg\";"
                                                                                "label=\"出图比例：\";"
                                                                                (strcat "value=" %%$$zgstr ";")
                                                                                "}"
                                                                                "ok_only;}"
                                                                        )
      (write-line str file)
    )
    (close file)
    Dcl_File
  )
        (setq %%$$GJstr (if %%$$GJstr (strcat %%$$GJstr) "\"DN300\""))
        (setq %%$$PDJstr (if %%$$PDJstr %%$$PDJstr "\"2.0%\""))
        (setq %%$$zgstr (if %%$$zgstr %%$$zgstr "1.0"))

网友答: 按照惯例，还是应该发个截图~~~



网友答: 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. )


网友答: 程序不错，有实用价值

网友答: 本帖最后由 l18c19 于 2016-4-20 16:46 编辑

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

向1、3楼请教，修改什么地方能将L=.?m后面的？由保留1位小数，变成保留3位（？？？）小数。谢谢！

网友答: 显示单位不准的

网友答: @77077 楼主，我想问下您修改的程序能不能改成把位置固定在线中的位置啊

网友答: 谢谢分享！！！

网友答: 参考我的帖子：
http://bbs.mjtd.com/thread-176541-1-1.html
画线的时候即标注，不是更省事吗？


网友答: 感谢 77077 ！感谢guangdonglbq！根据你们的的程序修改到我需要的管线标注了，花了不少时间，大家帮忙验证
  • 上一篇：框选统计圆数量程序改善
  • 下一篇：没有了
    CAD技术交流中心 | 建筑CAD | 给排水CAD | 暖通CAD | 电气CAD | 电力CAD | 机械CAD | CAD母线槽 | CAD看图
    Copyright © 2019 - 2025