管线标注程序改版

77077 · 发表于 2016-4-19 16:44:58

管线标注已经有各位大神写过，我写这个只是根据个人需求对原程序进行调整，要谢就谢开心长老吧。
开心长老的原帖地址http://bbs.mjtd.com/forum.php?mo ... &fromuid=253837
改造如下：
1.点选直线或者多段线，自动判断前点后点，求出两点间距离。
2.有时候自动标注出来的字会与其他字重叠，故改造成手动选择标注位置。

(VL-LOAD-COM)
(defun c:GXBZ (/ fz Write_Dcl gj pd zg DCL_ID ent obj pt1 pt2 dst a1 str gr
tObj
)
(setvar "CMDECHO" 0)
(defun fz ()
(setq gj (GET_tile "gj"))
(setq pd (GET_TILE "pd"))
(setq zg (atof (GET_TILE "zg")))
) ;;;临时生成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 '("RECT:dialog" "{label="管道标注";"
":edit_box {key="gj";label="管径：";value="DN300";}"
":edit_box {key="pd";label="坡度：";value="2.0%";}"
":edit_box {key="zg";label="字高：";value="2.5";}" "ok_only;}"
)
(write-line str file)
)
(close file)
Dcl_File
)
(SETQ DCL_ID (LOAD_DIALOG (setq Dcl_File (Write_Dcl))))
(vl-file-delete Dcl_File)
(NEW_DIALOG "RECT" DCL_ID)
(ACTION_TILE "accept" "(fz) (DONE_DIALOG)")
(START_DIALOG)
(UNLOAD_DIALOG DCL_ID)
(while (setq ent (entsel "\n 选择直线或多段线："))
(setq p (cadr ent);所击点
ent (car ent);所击线条
obj (vlax-ename->vla-object ent)
objname (vla-get-ObjectName obj)
)
(cond
((wcmatch ObjName "*Polyline")
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0));所击点最近的位置
n (fix (vlax-curve-getparamatpoint obj pp));所击点在第几段
pt1 (vlax-curve-getPointAtParam obj n);前点位置
pt2 (vlax-curve-getPointAtParam obj (1+ n));后点位置
dst (- (vlax-curve-getDistAtPoint obj pt2)
(vlax-curve-getDistAtPoint obj pt1)
);距离
str (strcat gj " L=" (rtos dst 2 1) "m i=" pd);字符串
)
(setq a1 (angle pp (mapcar
'+
pp
(vlax-curve-getfirstderiv obj
(vlax-curve-getparamatpoint obj pp)
)
)
)
);切线角度
(if (> (car pt1) (car pt2))
(setq a1 (+ a1 pi))
)
)
((wcmatch ObjName "AcDbLine")
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0));所击点最近的位置
pt1 (vlax-curve-getStartPoint obj);起点
pt2 (vlax-curve-getEndPoint obj);终点
dst (vla-get-Length obj);距离
str (strcat gj " L=" (rtos dst 2 1) "m i=" pd);字符串
)
(setq a1 (angle pt1 pt2))
(if (> (car pt1) (car pt2))
(setq a1 (+ a1 pi))
)
)
(t
(princ "\n 不支持的类型。")
(setq str nil)
)
);cond
(if (and
str
pp
zg
a1
)
(progn
(setq tObj (vlax-ename->vla-object (entmakex (list '(0 . "TEXT")
(cons 1 str)
(cons 8 "DM-管线标注")
(cons 10 pp)
(cons 40 zg)
(cons 50 a1) '
(71 . 0) '
(72 . 4)
(cons 11 pp) '
(73 . 2)
)
)
)
)
(while (and
tObj
(setq gr (grread 't 5 0))
(not (eq 3 (car gr)))
);只要不点击左键，一直循环
(cond
((eq 5 (car gr))
(vla-put-TextAlignmentPoint tObj (vlax-3D-point
(trans
(cadr gr)
1 0
)
)
)
)
(t
nil
)
)
);while
)
)
);while
(princ)
)

(VL-LOAD-COM) 
(defun c:GXBZ (/ fz Write_Dcl gj pd zg DCL_ID ent obj pt1 pt2 dst a1 str gr 
                 tObj 
              ) 
  (setvar "CMDECHO" 0) 
  (defun fz () 
    (setq gj (GET_tile "gj")) 
    (setq pd (GET_TILE "pd")) 
    (setq zg (atof (GET_TILE "zg"))) 
  )  ;;;临时生成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 '("RECT:dialog" "{label="管道标注";" 
       ":edit_box {key="gj";label="管径：";value="DN300";}" 
       ":edit_box {key="pd";label="坡度：";value="2.0%";}" 
       ":edit_box {key="zg";label="字高：";value="2.5";}" "ok_only;}" 
      ) 
      (write-line str file) 
    ) 
    (close file) 
    Dcl_File 
  ) 
  (SETQ DCL_ID (LOAD_DIALOG (setq Dcl_File (Write_Dcl)))) 
  (vl-file-delete Dcl_File) 
  (NEW_DIALOG "RECT" DCL_ID) 
  (ACTION_TILE "accept" "(fz) (DONE_DIALOG)") 
  (START_DIALOG) 
  (UNLOAD_DIALOG DCL_ID) 
  (while (setq ent (entsel "\n 选择直线或多段线：")) 
    (setq p (cadr ent);所击点 
          ent (car ent);所击线条 
          obj (vlax-ename->vla-object ent) 
          objname (vla-get-ObjectName obj) 
    ) 
    (cond 
      ((wcmatch ObjName "*Polyline") 
        (setq pp (vlax-curve-getclosestpointto obj (trans p 1 0));所击点最近的位置 
              n (fix (vlax-curve-getparamatpoint obj pp));所击点在第几段 
              pt1 (vlax-curve-getPointAtParam obj n);前点位置 
              pt2 (vlax-curve-getPointAtParam obj (1+ n));后点位置 
              dst (- (vlax-curve-getDistAtPoint obj pt2) 
                     (vlax-curve-getDistAtPoint obj pt1) 
                  );距离 
              str (strcat gj " L=" (rtos dst 2 1) "m i=" pd);字符串 
 
        ) 
        (setq a1 (angle pp (mapcar 
                             '+ 
                             pp 
                             (vlax-curve-getfirstderiv obj 
                                                       (vlax-curve-getparamatpoint obj pp) 
                             ) 
                           ) 
                 ) 
        );切线角度 
        (if (> (car pt1) (car pt2)) 
          (setq a1 (+ a1 pi)) 
        ) 
      ) 
      ((wcmatch ObjName "AcDbLine") 
        (setq pp (vlax-curve-getclosestpointto obj (trans p 1 0));所击点最近的位置 
              pt1 (vlax-curve-getStartPoint obj);起点 
              pt2 (vlax-curve-getEndPoint obj);终点 
              dst (vla-get-Length obj);距离 
              str (strcat gj " L=" (rtos dst 2 1) "m i=" pd);字符串 
 
        ) 
        (setq a1 (angle pt1 pt2)) 
        (if (> (car pt1) (car pt2)) 
          (setq a1 (+ a1 pi)) 
        ) 
      ) 
      (t 
        (princ "\n 不支持的类型。") 
        (setq str nil) 
      ) 
    );cond 
    (if (and 
          str 
          pp 
          zg 
          a1 
        ) 
      (progn 
        (setq tObj (vlax-ename->vla-object (entmakex (list '(0 . "TEXT") 
                                                           (cons 1 str) 
                                                           (cons 8 "DM-管线标注") 
                                                           (cons 10 pp) 
                                                           (cons 40 zg) 
                                                           (cons 50 a1) ' 
                                                           (71 . 0) ' 
                                                           (72 . 4) 
                                                           (cons 11 pp) ' 
                                                           (73 . 2) 
                                                     ) 
                                           ) 
                   ) 
        ) 
        (while (and 
                 tObj 
                 (setq gr (grread 't 5 0)) 
                 (not (eq 3 (car gr))) 
               );只要不点击左键，一直循环 
          (cond 
            ((eq 5 (car gr)) 
              (vla-put-TextAlignmentPoint tObj (vlax-3D-point 
                                                              (trans 
                                                                     (cadr gr) 
                                                                     1 0 
                                                              ) 
                                               ) 
              ) 
            ) 
            (t 
              nil 
            ) 
          ) 
        );while 
      ) 
    ) 
  );while 
  (princ) 
)

guankuiwu · 发表于 2024-7-5 14:42:10

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"))

77077 · 发表于 2016-4-19 16:51:09

按照惯例，还是应该发个截图~~~

dabingrain · 发表于 2016-4-20 00:13:16

GOOD，修改了一下，可以不显示坡度了

(VL-LOAD-COM)
(defun c:GXBZ (/ fz Write_Dcl gj pd zg DCL_ID ent obj pt1 pt2 dst a1 str gr
tObj
)
(setvar "CMDECHO" 0)
(defun fz ()
(setq gj (GET_tile "gj"))
(setq pd (GET_TILE "pd"))
(setq zg (atof (GET_TILE "zg")))
) ;;;临时生成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 '("RECT:dialog" "{label=\"管道标注\";"
":edit_box {key=\"gj\";label=\"管径：\";value=\"DN300\";}"
":edit_box {key=\"pd\";label=\"坡度：\";value=\"2.0%\";}"
":edit_box {key=\"zg\";label=\"字高：\";value=\"2.5\";}" "ok_only;}"
)
(write-line str file)
)
(close file)
Dcl_File
)
(SETQ DCL_ID (LOAD_DIALOG (setq Dcl_File (Write_Dcl))))
(vl-file-delete Dcl_File)
(NEW_DIALOG "RECT" DCL_ID)
(ACTION_TILE "accept" "(fz) (DONE_DIALOG)")
(START_DIALOG)
(UNLOAD_DIALOG DCL_ID)
(while (setq ent (entsel "\n 选择直线或多段线："))
(setq p (cadr ent);所击点
ent (car ent);所击线条
obj (vlax-ename->vla-object ent)
objname (vla-get-ObjectName obj)
)
(cond
((wcmatch ObjName "*Polyline")
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0));所击点最近的位置
n (fix (vlax-curve-getparamatpoint obj pp));所击点在第几段
pt1 (vlax-curve-getPointAtParam obj n);前点位置
pt2 (vlax-curve-getPointAtParam obj (1+ n));后点位置
dst (- (vlax-curve-getDistAtPoint obj pt2)
(vlax-curve-getDistAtPoint obj pt1)
);距离
str (strcat gj " L=" (rtos dst 2 1) "m" (if(/= pd "") (strcat " i=" pd) ""));字符串
)
(setq a1 (angle pp (mapcar
'+
pp
(vlax-curve-getfirstderiv obj
(vlax-curve-getparamatpoint obj pp)
)
)
)
);切线角度
(if (> (car pt1) (car pt2))
(setq a1 (+ a1 pi))
)
)
((wcmatch ObjName "AcDbLine")
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0));所击点最近的位置
pt1 (vlax-curve-getStartPoint obj);起点
pt2 (vlax-curve-getEndPoint obj);终点
dst (vla-get-Length obj);距离
str (strcat gj " L=" (rtos dst 2 1) "m" (if(/= pd "") (strcat " i=" pd) ""));字符串
)
(setq a1 (angle pt1 pt2))
(if (> (car pt1) (car pt2))
(setq a1 (+ a1 pi))
)
)
(t
(princ "\n 不支持的类型。")
(setq str nil)
)
);cond
(if (and
str
pp
zg
a1
)
(progn
(setq tObj (vlax-ename->vla-object (entmakex (list '(0 . "TEXT")
(cons 1 str)
(cons 8 "DM-管线标注")
(cons 10 pp)
(cons 40 zg)
(cons 50 a1) '
(71 . 0) '
(72 . 4)
(cons 11 pp) '
(73 . 2)
)
)
)
)
(while (and
tObj
(setq gr (grread 't 5 0))
(not (eq 3 (car gr)))
);只要不点击左键，一直循环
(cond
((eq 5 (car gr))
(vla-put-TextAlignmentPoint tObj (vlax-3D-point
(trans
(cadr gr)
1 0
)
)
)
)
(t
nil
)
)
);while
)
)
);while
(princ)
)

(VL-LOAD-COM) 
(defun c:GXBZ (/ fz Write_Dcl gj pd zg DCL_ID ent obj pt1 pt2 dst a1 str gr 
                                                                tObj 
              ) 
  (setvar "CMDECHO" 0) 
  (defun fz () 
    (setq gj (GET_tile "gj")) 
    (setq pd (GET_TILE "pd")) 
    (setq zg (atof (GET_TILE "zg"))) 
  )  ;;;临时生成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 '("RECT:dialog" "{label=\"管道标注\";" 
                                                                                ":edit_box {key=\"gj\";label=\"管径：\";value=\"DN300\";}" 
                                                                                ":edit_box {key=\"pd\";label=\"坡度：\";value=\"2.0%\";}" 
                                                                                ":edit_box {key=\"zg\";label=\"字高：\";value=\"2.5\";}" "ok_only;}" 
                                                                        ) 
      (write-line str file) 
    ) 
    (close file) 
    Dcl_File 
  ) 
  (SETQ DCL_ID (LOAD_DIALOG (setq Dcl_File (Write_Dcl)))) 
  (vl-file-delete Dcl_File) 
  (NEW_DIALOG "RECT" DCL_ID) 
  (ACTION_TILE "accept" "(fz) (DONE_DIALOG)") 
  (START_DIALOG) 
  (UNLOAD_DIALOG DCL_ID) 
  (while (setq ent (entsel "\n 选择直线或多段线：")) 
    (setq p (cadr ent);所击点 
                        ent (car ent);所击线条 
                        obj (vlax-ename->vla-object ent) 
                        objname (vla-get-ObjectName obj) 
    ) 
    (cond 
      ((wcmatch ObjName "*Polyline") 
        (setq pp (vlax-curve-getclosestpointto obj (trans p 1 0));所击点最近的位置 
                                        n (fix (vlax-curve-getparamatpoint obj pp));所击点在第几段 
                                        pt1 (vlax-curve-getPointAtParam obj n);前点位置 
                                        pt2 (vlax-curve-getPointAtParam obj (1+ n));后点位置 
                                        dst (- (vlax-curve-getDistAtPoint obj pt2) 
                                                                (vlax-curve-getDistAtPoint obj pt1) 
                                                        );距离 
                                        str (strcat gj " L=" (rtos dst 2 1) "m" (if(/= pd "") (strcat " i=" pd) ""));字符串 
        ) 
        (setq a1 (angle pp (mapcar 
                             '+ 
                             pp 
                             (vlax-curve-getfirstderiv obj 
                                                                                                                         (vlax-curve-getparamatpoint obj pp) 
                             ) 
                           ) 
                 ) 
        );切线角度 
        (if (> (car pt1) (car pt2)) 
          (setq a1 (+ a1 pi)) 
        ) 
      ) 
      ((wcmatch ObjName "AcDbLine") 
        (setq pp (vlax-curve-getclosestpointto obj (trans p 1 0));所击点最近的位置 
                                        pt1 (vlax-curve-getStartPoint obj);起点 
                                        pt2 (vlax-curve-getEndPoint obj);终点 
                                        dst (vla-get-Length obj);距离 
                                        str (strcat gj " L=" (rtos dst 2 1) "m" (if(/= pd "") (strcat " i=" pd) ""));字符串 
        ) 
        (setq a1 (angle pt1 pt2)) 
        (if (> (car pt1) (car pt2)) 
          (setq a1 (+ a1 pi)) 
        ) 
      ) 
      (t 
        (princ "\n 不支持的类型。") 
        (setq str nil) 
      ) 
    );cond 
    (if (and 
          str 
          pp 
          zg 
          a1 
        ) 
      (progn 
        (setq tObj (vlax-ename->vla-object (entmakex (list '(0 . "TEXT") 
                                                                                                                                                                                                                         (cons 1 str) 
                                                                                                                                                                                                                         (cons 8 "DM-管线标注") 
                                                                                                                                                                                                                         (cons 10 pp) 
                                                                                                                                                                                                                         (cons 40 zg) 
                                                                                                                                                                                                                         (cons 50 a1) ' 
                                                                                                                                                                                                                         (71 . 0) ' 
                                                                                                                                                                                                                         (72 . 4) 
                                                                                                                                                                                                                         (cons 11 pp) ' 
                                                                                                                                                                                                                         (73 . 2) 
                                                     ) 
                                           ) 
                   ) 
        ) 
        (while (and 
                 tObj 
                 (setq gr (grread 't 5 0)) 
                 (not (eq 3 (car gr))) 
               );只要不点击左键，一直循环 
          (cond 
            ((eq 5 (car gr)) 
              (vla-put-TextAlignmentPoint tObj (vlax-3D-point 
                                                                                                                                                                                                 (trans 
                                                                                                                                                                                                         (cadr gr) 
                                                                                                                                                                                                         1 0 
                                                                                                                                                                                                 ) 
                                               ) 
              ) 
            ) 
            (t 
              nil 
            ) 
          ) 
        );while 
      ) 
    ) 
  );while 
  (princ) 
)

USER2128 · 发表于 2016-4-20 08:16:51

程序不错，有实用价值

l18c19 · 发表于 2016-4-20 10:56:28

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

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

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

atest2016 · 发表于 2016-5-11 14:47:37

显示单位不准的

alpha223334 · 发表于 2018-7-17 07:53:04

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

土木燃 · 发表于 2018-7-17 18:16:46

谢谢分享！！！

fl202 · 发表于 2018-7-18 14:17:48

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

alpha223334 · 发表于 2018-7-19 07:50:26

感谢 77077 ！感谢guangdonglbq！根据你们的的程序修改到我需要的管线标注了，花了不少时间，大家帮忙验证

账号		自动登录	找回密码
密码			注册

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

相关帖子

本帖子中包含更多资源

评分

本帖子中包含更多资源

点评

评分