dwgplt 发表于 2003-2-17 14:34:00

龙龙仔 发表于 2003-2-19 08:03:00

只对直线有效..

;;---------------------------------------------------
;;****此程序功能是对管道线进行管径标注，其符号为DN。
;;****只对直线有效<Only work for 2000+>
;;---------------------------------------------------

(defun C:BDN (/             CMD_OLD           OS_OLD SS       SS1        SS2    PT
              PT0    PT1    PT2           ANG          DN       DN0        BDN_ER BDN_OE
              VOBJ   PNT    PARAM1 PARAM2
             )

(defun DXF (CODE ELIST)
    (cdr (assoc CODE ELIST))
)

(defun DO_IT ()
    (setq ANG0 (angle PT1 PT2))
    (if
      (and (> ANG0 (* pi 0.5)) (<= ANG0 (* pi 1.5)))
       (setq ANG0 (+ ANG0 pi))
    )
    (setq ANG (+ ANG0 (* pi 0.5)))
    (setq PT0 (polar PT ANG (* (getvar "textsize") 10)))
    (setq PT (inters PT1 PT2 PT0 PT NIL))
    (setq PT (polar PT ANG (* (getvar "textsize") 0.35)))
    (setq DN0 (rtos (distance PT1 PT2) 2 2))
    (setq DN (getstring (strcat "\n请输入该管道管径<" DN0 ">:")))
    (if
      (= DN "")
       (setq DN DN0)
       (setq DN0 DN)
    )
    (setq DN (strcat "DN" DN))
    (command "_.text"
             "C"
             PT
             (getvar "textsize")
             (angtos ANG0 0 3)
             DN
    )
)

(setq CMD_OLD (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq OS_OLD (getvar "osmode"))
(setvar "osmode" 0)
(defun BDN_ER        (S)
    (if        (/= MSG "功能取消")
      (if (= MSG "退出 / 中止")
        (princ)
        (princ (strcat "\n功能取消!"))
      )
    )
    (eval (read U:E))
    (if        BDN_OE
      (setq *ERROR* BDN_OE)
    )
    (if        temp
      (redraw temp 1)
    )
    (princ)
)
(if *ERROR*
    (setq BDN_OE*ERROR*
          *ERROR* BDN_ER
    )
    (setq *ERROR* BDN_ER)
)
(setq        U:G "(command \"undo\" \"group\")"
        U:E "(command \"undo\" \"en\")"
)
(while
    (setq SS (entsel "\n请拾取需标注管径的管道<回车退出>:"))
   (setq SS1 (entget (car SS)))
   (setq SS2 (DXF 0 SS1))
   (setq PT (osnap (trans (cadr SS) 1 0) "MID"))
   (cond
       ((= SS2 "LINE")
        (setq PT1 (DXF 10 SS1)
              PT2 (DXF 11 SS1)
        )
        (DO_IT)
       )
       ((or (= SS2 "LWPOLYLINE")
          (= SS2 "POLYLINE")
        )
        (setq VOBJ (vlax-ename->vla-object (car SS)))
        (setq PARAM1 (vlax-curve-getparamatpoint VOBJ PT))
        (setq PARAM1 (fix PARAM1))
        (setq PARAM2 (1+ PARAM1))
        (if (equal PARAM1 (vlax-curve-getstartparam VOBJ) 1e-10)
          (setq PT1 (vlax-curve-getstartpoint VOBJ))
          (setq PT1 (vlax-curve-getpointatparam VOBJ PARAM1))
        )
        (if (equal PARAM2 (vlax-curve-getendparam VOBJ) 1e-10)
          (setq PT2 (vlax-curve-getendpoint VOBJ))
          (setq PT2 (vlax-curve-getpointatparam VOBJ PARAM2))
        )
        (DO_IT)
       )
       (t
        (alert "\n所选像素不能进行管径标注!重新选取")
       )
   )
)
(setvar "cmdecho" CMD_OLD)
(setvar "osmode" OS_OLD)
(princ)
)
(prompt "\nEnter BDN to start")

dwgplt 发表于 2003-2-19 14:14:00

chg 发表于 2003-2-19 18:13:00

这个程序的缺陷在于对LwPOLYLINE资料分析不正确，所以有时会出错，龙大侠改正了它。

dwgplt 发表于 2003-2-19 20:40:00

ocoipw 发表于 2016-5-6 20:34:14

很想学学习
页: [1]
查看完整版本: 请大家帮忙看一下这个程序是否有缺陷？