求标注曲线（主要是多段线）两点之间的线长的插件
本帖最后由 清风明月名字 于 2014-3-8 08:31 编辑我想求一个标注多段线两点之间的长度的插件，这个多段线可以有直线，也可以弧线。当然也可以是针对所有曲线的插件。
我主要是碰到一个问题，例如读匝道的里程时，由于匝道的弯曲半径很小，所以读它的里程如果直接用垂直距离，误差会很大，如果是用两点间多段线的长度，则是从理论上来说，一点误差也没有的
这就是示例。如果直接量垂直线距离，则是极不准确的。非得计算两点之间的多段线长并标出来才是准确的。
看帖回帖是美德
;对象上两点长度
(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)
(setqpt1 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)
(setqpt2 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)
多谢啦！！
页:
[1]