屏幕打印并标注多段线每段的长度

marting · 发表于 2017-6-6 01:13:31

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

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

×

(defun c:plseglen (/ *adoc ss itmn coords pt ptl seg segd pta ptb ptab
txt txta)
(vl-load-com)
(setq *adoc (vla-get-activedocument (vlax-get-acad-object)))
(if (ssget '((0 . "LWPOLYLINE")))
(progn
(setq itmn 0)
(vlax-for itm (setq ss (vla-get-activeselectionset *adoc))
(setq itmn (1+ itmn))
(princ (strcat "\n\nPolyline number "
(itoa itmn)
" length :\t"
(rtos (vlax-curve-getdistatparam
itm
(vlax-curve-getendparam itm)
)
2
2
)
)
)
(setq coords (vlax-safearray->list
(vlax-variant-value (vla-get-coordinates itm))
)
)
(repeat (/ (length coords) 2)
(setq pt (list (car coords) (cadr coords)))
(setq coords (cddr coords))
(setq ptl (cons pt ptl))
)
(setq ptl (reverse ptl))
(setq seg 0)
(repeat (- (length ptl) 1)
(setq seg (1+ seg))
(princ
(strcat "\nSegment number " (itoa seg) " from point ")
)
(princ (setq pta (nth (- seg 1) ptl)))
(princ " to point ")
(princ (setq ptb (nth seg ptl)))
(princ " length : ")
(princ (setq segd
(rtos (- (vlax-curve-getdistatpoint itm (nth seg ptl))
(vlax-curve-getdistatpoint
itm
(nth (- seg 1) ptl)
)
)
2
2
)
)
)
(setq ptab (vlax-curve-getpointatparam
itm
(+ (vlax-curve-getparamatpoint itm pta)
(/ (- (vlax-curve-getparamatpoint itm ptb)
(vlax-curve-getparamatpoint itm pta)
)
2
)
)
)
)
(setq
txt (entmakex (list (cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 10 ptab)
(cons 40 (/ (getvar 'viewsize) 100))
(cons 1 segd)
(cons 50 (angle pta ptb))
(cons 41 1.0)
(cons 51 0.0)
(cons 71 0)
(cons 72 0)
(list 210 0.0 0.0 1.0)
(cons 100 "AcDbText")
(cons 73 0)
)
)
)
(setq txta (vlax-ename->vla-object txt))
(vla-put-alignment txta acAlignmentMiddleCenter)
(entmod
(subst (cons 11 ptab) (assoc 11 (entget txt)) (entget txt))
)
)
(if (= (vla-get-closed itm) :vlax-true)
(progn
(setq seg (1+ seg))
(princ
(strcat "\nSegment number " (itoa seg) " from point ")
)
(princ (setq pta (last ptl)))
(princ " to point ")
(princ (setq ptb (vlax-curve-getendpoint itm)))
(princ " length : ")
(princ (setq segd
(rtos (- (vlax-curve-getdistatparam
itm
(vlax-curve-getendparam itm)
)
(vlax-curve-getdistatpoint itm (last ptl))
)
2
2
)
)
)
(setq ptab (vlax-curve-getpointatparam
itm
(+ (vlax-curve-getparamatpoint itm pta)
(/ (- (vlax-curve-getendparam itm)
(vlax-curve-getparamatpoint itm pta)
)
2
)
)
)
)
(setq
txt (entmakex (list (cons 0 "TEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbText")
(cons 10 ptab)
(cons 40 (/ (getvar 'viewsize) 100))
(cons 1 segd)
(cons 50 (angle pta ptb))
(cons 41 1.0)
(cons 51 0.0)
(cons 71 0)
(cons 72 0)
(list 210 0.0 0.0 1.0)
(cons 100 "AcDbText")
(cons 73 0)
)
)
)
(setq txta (vlax-ename->vla-object txt))
(vla-put-alignment txta acAlignmentMiddleCenter)
(entmod (subst (cons 11 ptab)
(assoc 11 (entget txt))
(entget txt)
)
)
)
)
(setq ptl nil)
)
(vla-delete ss)
)
)
(textpage)
(princ)
)

(defun c:plseglen (/ *adoc ss itmn coords pt ptl seg segd pta ptb ptab 
                   txt txta) 
  (vl-load-com) 
  (setq *adoc (vla-get-activedocument (vlax-get-acad-object))) 
  (if (ssget '((0 . "LWPOLYLINE"))) 
    (progn 
      (setq itmn 0) 
      (vlax-for itm (setq ss (vla-get-activeselectionset *adoc)) 
        (setq itmn (1+ itmn)) 
        (princ (strcat "\n\nPolyline number " 
                       (itoa itmn) 
                       " length :\t" 
                       (rtos (vlax-curve-getdistatparam 
                               itm 
                               (vlax-curve-getendparam itm) 
                             ) 
                             2 
                             2 
                       ) 
               ) 
        ) 
        (setq coords (vlax-safearray->list 
                       (vlax-variant-value (vla-get-coordinates itm)) 
                     ) 
        ) 
        (repeat (/ (length coords) 2) 
          (setq pt (list (car coords) (cadr coords))) 
          (setq coords (cddr coords)) 
          (setq ptl (cons pt ptl)) 
        ) 
        (setq ptl (reverse ptl)) 
        (setq seg 0) 
        (repeat (- (length ptl) 1) 
          (setq seg (1+ seg)) 
          (princ 
            (strcat "\nSegment number " (itoa seg) " from point ") 
          ) 
          (princ (setq pta (nth (- seg 1) ptl))) 
          (princ " to point ") 
          (princ (setq ptb (nth seg ptl))) 
          (princ " length : ") 
          (princ (setq segd 
                        (rtos (- (vlax-curve-getdistatpoint itm (nth seg ptl)) 
                                 (vlax-curve-getdistatpoint 
                                   itm 
                                   (nth (- seg 1) ptl) 
                                 ) 
                              ) 
                              2 
                              2 
                        ) 
                 ) 
          ) 
          (setq ptab (vlax-curve-getpointatparam 
                       itm 
                       (+ (vlax-curve-getparamatpoint itm pta) 
                          (/ (- (vlax-curve-getparamatpoint itm ptb) 
                                (vlax-curve-getparamatpoint itm pta) 
                             ) 
                             2 
                          ) 
                       ) 
                     ) 
          ) 
          (setq 
            txt (entmakex (list (cons 0 "TEXT") 
                                (cons 100 "AcDbEntity") 
                                (cons 100 "AcDbText") 
                                (cons 10 ptab) 
                                (cons 40 (/ (getvar 'viewsize) 100)) 
                                (cons 1 segd) 
                                (cons 50 (angle pta ptb)) 
                                (cons 41 1.0) 
                                (cons 51 0.0) 
                                (cons 71 0) 
                                (cons 72 0) 
                                (list 210 0.0 0.0 1.0) 
                                (cons 100 "AcDbText") 
                                (cons 73 0) 
                          ) 
                ) 
          ) 
          (setq txta (vlax-ename->vla-object txt)) 
          (vla-put-alignment txta acAlignmentMiddleCenter) 
          (entmod 
            (subst (cons 11 ptab) (assoc 11 (entget txt)) (entget txt)) 
          ) 
        ) 
        (if (= (vla-get-closed itm) :vlax-true) 
          (progn 
            (setq seg (1+ seg)) 
            (princ 
              (strcat "\nSegment number " (itoa seg) " from point ") 
            ) 
            (princ (setq pta (last ptl))) 
            (princ " to point ") 
            (princ (setq ptb (vlax-curve-getendpoint itm))) 
            (princ " length : ") 
            (princ (setq segd 
                          (rtos (- (vlax-curve-getdistatparam 
                                     itm 
                                     (vlax-curve-getendparam itm) 
                                   ) 
                                   (vlax-curve-getdistatpoint itm (last ptl)) 
                                ) 
                                2 
                                2 
                          ) 
                   ) 
            ) 
            (setq ptab (vlax-curve-getpointatparam 
                         itm 
                         (+ (vlax-curve-getparamatpoint itm pta) 
                            (/ (- (vlax-curve-getendparam itm) 
                                  (vlax-curve-getparamatpoint itm pta) 
                               ) 
                               2 
                            ) 
                         ) 
                       ) 
            ) 
            (setq 
              txt (entmakex (list (cons 0 "TEXT") 
                                  (cons 100 "AcDbEntity") 
                                  (cons 100 "AcDbText") 
                                  (cons 10 ptab) 
                                  (cons 40 (/ (getvar 'viewsize) 100)) 
                                  (cons 1 segd) 
                                  (cons 50 (angle pta ptb)) 
                                  (cons 41 1.0) 
                                  (cons 51 0.0) 
                                  (cons 71 0) 
                                  (cons 72 0) 
                                  (list 210 0.0 0.0 1.0) 
                                  (cons 100 "AcDbText") 
                                  (cons 73 0) 
                            ) 
                  ) 
            ) 
            (setq txta (vlax-ename->vla-object txt)) 
            (vla-put-alignment txta acAlignmentMiddleCenter) 
            (entmod (subst (cons 11 ptab) 
                           (assoc 11 (entget txt)) 
                           (entget txt) 
                    ) 
            ) 
          ) 
        ) 
        (setq ptl nil) 
      ) 
      (vla-delete ss) 
    ) 
  ) 
  (textpage) 
  (princ) 
)

searinon · 发表于 2017-6-6 06:08:48

这个厉害了。

zjy2999 · 发表于 2017-6-6 08:36:35

标注距离不压线最好，谢谢楼主提供程序！！！！！

yufeng37 · 发表于 2017-6-6 09:39:18

好用的，感谢楼主分享

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

[每日一码] 屏幕打印并标注多段线每段的长度

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