管线标注程序改版

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

管线标注已经有各位大神写过，我写这个只是根据个人需求对原程序进行调整，要谢就谢开心长老吧。
开心长老的原帖地址http://bbs.mjtd.com/forum.php?mod=redirect&goto=findpost&ptid=106784&pid=602428&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)
)

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

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！根据你们的的程序修改到我需要的管线标注了，花了不少时间，大家帮忙验证

页: [1] 2 3

明经CAD社区's Archiver

管线标注程序改版