在多段线上拖动标注文字

marting · 发表于 2017-2-16 22:49:33

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

(defun c:plLen (/ cEnt tStr tBox tHgt tWid gr sPt cPt lAng bPt tPt pt1
                pt2 pt3        pt4)
  (vl-load-com)
  (if (and (setq cEnt (car (entsel "\nSelect Object: ")))
           (member (cdr (assoc 0 (entget cEnt)))
                   '("LWPOLYLINE" "POLYLINE" "LINE")
           ) ;_ end of member
      ) ;_ end of and
    (progn
      (setq tStr (rtos (vla-get-length
                         (vlax-ename->vla-object cEnt)
                       ) ;_ end of vla-get-length
                       2
                       2
                 ) ;_ end of rtos
            tBox (textbox (list (cons 1 tStr) (cons 40 (getvar "TEXTSIZE")))
                 ) ;_ end of textbox
            tHgt (- (cadadr tBox) (cadar tBox))
            twid (- (caadr tBox) (caar tBox))
      ) ;_ end of setq
      (princ "\nPosition Text...")
      (while (eq 5 (car (setq gr (grread t 5 0))))
        (redraw)
        (if (listp (setq sPt (cadr gr)))
          (progn
            (setq cPt  (vlax-curve-getClosestPointto cEnt sPt)
                  lAng (angle cPt sPt)
                  bpt  (polar cPt lAng (/ (getvar "TEXTSIZE") 2.))
                  tpt  (polar bpt lAng tHgt)
                  mPt  (polar bPt lAng (/ tHgt 2.))
                  pt1  (polar bpt (+ lAng (/ pi 2.)) (/ tWid 2.))
                  pt2  (polar bPt (- lAng (/ pi 2.)) (/ tWid 2.))
                  pt3  (polar tpt (+ lAng (/ pi 2.)) (/ tWid 2.))
                  pt4  (polar tPt (- lAng (/ pi 2.)) (/ tWid 2.))
            ) ;_ end of setq
            (grvecs (list -3 pt1 pt2 pt3 pt4 pt1 pt3 pt2 pt4))
          ) ;_ end of progn
        ) ;_ end of if
      ) ;_ end of while
      (if (eq 3 (car gr))
        (progn
          (setq lAng (- lAng (/ pi 2.)))
          (cond        ((and (> lAng (/ pi 2)) (<= lAng pi))
                 (setq lAng (- lAng pi))
                )
                ((and (> lAng pi) (<= lAng (/ (* 3 pi) 2)))
                 (setq lAng (+ lAng pi))
                )
          ) ;_ end of cond
          (Make_Text mPt tStr lAng)
        ) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of progn
    (princ "\n<!> Incorrect Selection <!>")
  ) ;_ end of if
  (redraw)
  (princ)
) ;_ end of defun

函数 Make_Text:

游客，如果您要查看本帖隐藏内容请回复

kqqt6236 · 发表于 2017-2-17 00:01:59

正需要，支持楼主大人了！

yoyoho · 发表于 2017-2-17 08:17:51

确实是难得好帖啊，顶先一下!!!!

ynhh · 发表于 2017-2-17 08:38:51

感谢你的分享
谢谢你

HLCAD · 发表于 2017-2-17 08:57:17

非常好程序，非常感谢楼主！！！

819534890 · 发表于 2017-2-17 09:42:06

回复学习，谢谢分享

508000096 · 发表于 2017-2-17 10:06:16

很炫的效果。

zhangq_cai1 · 发表于 2017-2-17 13:12:19

啥也不说了，感谢楼主分享哇！

434939575 · 发表于 2017-2-17 20:01:47

这个挺好玩的！

cq_qg68 · 发表于 2017-2-17 21:39:55

看看函数 Make_Text

zdqwy19 · 发表于 2017-2-18 09:16:03

本帖最后由 zdqwy19 于 2017-2-18 21:43 编辑

修改了一下。

向嘟嘟 · 发表于 2017-2-18 10:11:17

感谢楼主分享

sachindkini · 发表于 2017-2-18 13:43:05

wow nice ...............

zengqingyi · 发表于 2017-2-18 21:50:32

能否输入比例？

Lisphk · 发表于 2017-2-18 21:59:48

zdqwy19 发表于 2017-2-18 09:16

代码分享下

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

[每日一码] 在多段线上拖动标注文字

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。