求标注曲线（主要是多段线）两点之间的线长的插件

清风明月名字

我想求一个标注多段线两点之间的长度的插件，这个多段线可以有直线，也可以弧线。当然也可以是针对所有曲线的插件。
我主要是碰到一个问题，例如读匝道的里程时，由于匝道的弯曲半径很小，所以读它的里程如果直接用垂直距离，误差会很大，如果是用两点间多段线的长度，则是从理论上来说，一点误差也没有的
这就是示例。如果直接量垂直线距离，则是极不准确的。非得计算两点之间的多段线长并标出来才是准确的。

852456

看帖回帖是美德

2496653555

;对象上两点长度
(defun c:chainlen ( / len lst pt1 pt2 sel tmp )
    (if
        (and
            (setq sel
                (ssget
                    (list
                       '(-4 . "<OR")
                           '(0 . "LINE,ARC")
                           '(-4 . "<AND")
                               '(0 . "LWPOLYLINE,SPLINE")
                               '(-4 . "<NOT")
                                   '(-4 . "&=")
                                   '(70 . 1)
                               '(-4 . "NOT>")
                           '(-4 . "AND>")
                           '(-4 . "<AND")
                               '(0 . "POLYLINE")
                               '(-4 . "<NOT")
                                   '(-4 . "&")
                                   '(70 . 89)
                               '(-4 . "NOT>")
                               '(-4 . "AND>")
                           '(-4 . "<AND")
                               '(0 . "ELLIPSE")
                               '(-4 . "<OR")
                                   '(-4 . "<>")
                                   '(41 . 0.0)
                                   '(-4 . "<>")
                                    (cons 42 (+ pi pi))
                               '(-4 . "OR>")
                           '(-4 . "AND>")
                       '(-4 . "OR>")
                        (if (= 1 (getvar 'cvport))
                            (cons 410 (getvar 'ctab))
                           '(410 . "Model")
                        )
                    )
                )
            )
            (setq pt1 (getpoint "\nSpecify 1st point: "))
            (setq pt2 (getpoint "\nSpecify 2nd point: " pt1))
        )
        (if
            (setq tmp
                (vl-member-if
                    (function
                        (lambda ( itm / tmp )
                            (cond
                                (   (equal pt1 (setq tmp (vlax-curve-getclosestpointto (cadr itm) pt1)) 1e-3)
                                    (setq  pt1 tmp)
                                )
                                (   (equal pt2 (setq tmp (vlax-curve-getclosestpointto (cadr itm) pt2)) 1e-3)
                                    (mapcar 'set '(pt1 pt2) (list tmp pt1))
                                )
                            )
                        )
                    )
                    (LM:sortedchainselection sel)
                )
                lst
                (vl-member-if
                    (function
                        (lambda ( itm / tmp )
                            (if (equal pt2 (setq tmp (vlax-curve-getclosestpointto (cadr itm) pt2)) 1e-3)
                                (setq  pt2 tmp)
                            )
                        )
                    )
                    (reverse tmp)
                )
            )
            (progn
                (if (cdr lst)
                    (setq len
                        (+
                            (abs
                                (- (vlax-curve-getdistatpoint (cadar tmp) pt1)
                                   (vlax-curve-getdistatpoint (cadar tmp) (caddar tmp))
                                )
                            )
                            (abs
                                (- (vlax-curve-getdistatpoint (cadar lst) pt2)
                                   (vlax-curve-getdistatpoint (cadar lst) (caar lst))
                                )
                            )
                        )
                    )
                    (setq len
                        (abs
                            (-  (vlax-curve-getdistatpoint (cadar lst) pt1)
                                (vlax-curve-getdistatpoint (cadar lst) pt2)
                            )
                        )
                    )
                )
                (foreach itm (cdr (reverse (cdr lst)))
                    (setq len (+ len (vlax-curve-getdistatparam (cadr itm) (vlax-curve-getendparam (cadr itm)))))
                )
                (princ (strcat "\nLength: " (rtos len)))
            )
            (princ "\nThe selected points do not lie on the same chain of objects.")
        )
    )
    (princ)
)

(defun LM:sortedchainselection ( sel / end ent flg idx lst rtn tmp )
    (repeat (setq idx (sslength sel))
        (setq ent (ssname sel (setq idx (1- idx)))
              lst (cons (list (vlax-curve-getstartpoint ent) ent (vlax-curve-getendpoint ent)) lst)
        )
    )
    (setq end (list (caar lst) (caddar lst))
          rtn (list (car lst))
          lst (cdr lst)
    )
    (while
        (progn
            (foreach itm lst
                (cond
                    (   (equal (car itm) (car end) 1e-8)
                        (setq end (cons (caddr itm) (cdr end))
                              rtn (cons (reverse itm) rtn)
                              flg t
                        )
                    )
                    (   (equal (car itm) (cadr end) 1e-8)
                        (setq end (list (car end) (caddr itm))
                              rtn (append rtn (list itm))
                              flg t
                        )
                    )
                    (   (equal (caddr itm) (car end) 1e-8)
                        (setq end (cons (car itm) (cdr end))
                              rtn (cons itm rtn)
                              flg t
                        )
                    )
                    (   (equal (caddr itm) (cadr end) 1e-8)
                        (setq end (list (car end) (car itm))
                              rtn (append rtn (list (reverse itm)))
                              flg t
                        )
                    )
                    (   (setq tmp (cons itm tmp)))
                )
            )
            flg
        )
        (setq lst tmp tmp nil flg nil)
    )
    rtn
)(vl-load-com)

guankuiwu

多谢啦！！