曲线局部长度插件反向改编
原代码是在论坛找的,感谢原作者,主要功能是点取曲线上两点,获取两点间距离,此次增加功能是对于首尾相连的曲线,有时候想获取的两点间的距离是和原插件获取的相反的部分的长度,请大声伸下援手哈,最好是直接按T键直接转换 本帖最后由 yaojing38 于 2023-6-11 23:14 编辑15062311027 发表于 2023-6-11 22:33
你好 这么晚了还打扰你哈 现在提示错误: 输入的字符串有缺陷
还有我意思是比如截取两点间距离 ,发现亮 ...
;测量曲线上两点间的路程长度.
(defun C:qjcd (/ entName1 Pt1 Pt2 xLen st_pt end_pt pt_tmp l_ss PD pd1 obj)
(vl-load-com)
(setq entName1 (car (entselEx"\r请选择直线、圆弧、圆、多段线等曲线:" '((0 . "line,arc,circle,lwpolyline")))))
(setq obj (vlax-ename->vla-object entName1))
(setq PD (< (distance (vlax-curve-getStartPoint obj) (vlax-curve-getEndPoint obj)) 0.0001))
(setq pt1 (getpoint "\n指定测量起点: ")
pt2 (getpoint "\n指定测量终点: ")
)
(setq
st_pt (vlax-curve-getStartPoint entName1)
end_pt (vlax-curve-getEndPoint entName1)
)
(setq entName2 entName1)
(if (>(vlax-curve-getParamAtPoint entName1 pt1) (vlax-curve-getParamAtPoint entName1 pt2))
(setq pt_tmp pt2
pt2 pt1
pt1 pt_tmp)
)
(vl-cmdf "undo" "be")
(vl-cmdf "_break" entName1 st_pt pt1)
(vl-cmdf "_break" entName1 end_pt pt2)
(vl-cmdf ".copy" entName1 "" '(0 0) '(0 0))
(setq l_ss (entget (entlast)))
(vl-cmdf "undo" "end")
(vl-cmdf "undo" "")
(entmake l_ss)
(setq entName1 (entlast))
(vla-put-Color (vlax-ename->vla-object entName1) 1)
(redraw entName1 3)
(initget 1 "T")
(setq pd1 (getstring "\n[取反向距离(T)]: ") )
(if (AND (or (= pd1 "t") (= pd1 "T")) PD)
(setq xLen (- (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj)) (abs (- (vlax-curve-getDistAtPoint entName1 pt1)(vlax-curve-getDistAtPoint entName1 pt2)))))
(setq xLen (abs (- (vlax-curve-getDistAtPoint entName1 pt1)(vlax-curve-getDistAtPoint entName1 pt2))))
)
(if (AND (or (= pd1 "t") (= pd1 "T")) PD)
(progn
(vl-cmdf "_erase"entName1 "")
(if (>(vlax-curve-getParamAtPoint entName2 pt1) (vlax-curve-getParamAtPoint entName2 pt2))
(setq pt_tmp pt2
pt2 pt1
pt1 pt_tmp)
)
(vl-cmdf "undo" "be")
(vl-cmdf "_break" entName2PT1 pt2 )
;(vl-cmdf "_break" entName1end_ptpt1)
(vl-cmdf ".copy" entName2 "" '(0 0) '(0 0))
(setq l_ss (entget (entlast)))
(vl-cmdf "undo" "end")
(vl-cmdf "undo" "")
(entmake l_ss)
(setq entName2 (entlast))
(vla-put-Color (vlax-ename->vla-object entName2) 1)
(redraw entName2 3)
(vl-cmdf "_erase"entName2)
)
)
(vl-cmdf "_erase"entName1)
(princ (strcat "\n测量结果:两点间曲线长度=" (rtos xLen 2 2)))
(princ "\n路径检查:查看亮显区域,右键退出")
(princ)
)
你用原来命令QJCD ,提示取反不输入不取反 ;测量曲线上两点间的路程长度.
(defun C:T (/ entName1 Pt1 Pt2 xLen st_pt end_pt pt_tmp l_ss PDobj)
(vl-load-com)
(setq entName1 (car (entselEx"\r请选择直线、圆弧、圆、多段线等曲线:" '((0 . "line,arc,circle,lwpolyline")))))
(setq obj (vlax-ename->vla-object entName1))
(setq PD (< (distance (vlax-curve-getStartPoint obj) (vlax-curve-getEndPoint obj)) 0.0001))
(setq pt1 (getpoint "\n指定测量起点: ")
pt2 (getpoint "\n指定测量终点: ")
st_pt (vlax-curve-getStartPoint entName1)
end_pt (vlax-curve-getEndPoint entName1)
)
(if PD
(setq xLen (- (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj)) (abs (- (vlax-curve-getDistAtPoint entName1 pt1)(vlax-curve-getDistAtPoint entName1 pt2)))))
(setq xLen (abs (- (vlax-curve-getDistAtPoint entName1 pt1)
(vlax-curve-getDistAtPoint entName1 pt2))))
)
(if (>(vlax-curve-getParamAtPoint entName1 pt1) (vlax-curve-getParamAtPoint entName1 pt2))
(setq pt_tmp pt2
pt2 pt1
pt1 pt_tmp)
)
(vl-cmdf "undo" "be")
(vl-cmdf "_break" entName1 st_pt pt1)
(vl-cmdf "_break" entName1 end_pt pt2)
(vl-cmdf ".copy" entName1 "" '(0 0) '(0 0))
(setq l_ss (entget (entlast)))
(vl-cmdf "undo" "end")
(vl-cmdf "undo" "")
(entmake l_ss)
(setq entName1 (entlast))
(vla-put-Color (vlax-ename->vla-object entName1) 1)
(redraw entName1 3)
(vl-cmdf "_erase"entName1)
(princ (strcat "\n测量结果:两点间曲线长度=" (rtos xLen 2 2)))
(princ "\n路径检查:查看亮显区域,右键退出")
(princ)
)
你试下行不行 yaojing38 发表于 2023-6-11 22:11
;测量曲线上两点间的路程长度.
(defun C:T (/ entName1 Pt1 Pt2 xLen st_pt end_pt pt_tmp l_ss PDobj)
...
你好 这么晚了还打扰你哈 现在提示错误: 输入的字符串有缺陷
还有我意思是比如截取两点间距离 ,发现亮显段就是自己需要的段落就直接右键结束,否则如果发现亮显段和实际要测的段落刚好相反 则直接按一个键T或者其他字母 就亮显反向的那段,且输出反向那段长度 麻烦再看下哈 yaojing38 发表于 2023-6-11 12:20
你用原来命令QJCD ,提示取反不输入不取反
你好 现在基本满足了哈 还有两个小问题哈 第一个一旦按下T阿能先把曲线处理成闭合的(有时候曲线虽然首尾相连,但不是闭合的,这种情形插件不能准确识别反向测量区域) 第二个如果一开始选择的曲线段落就符合要求,看能不能改成直接按右键出结果退出 15062311027 发表于 2023-6-12 09:00
你好 现在基本满足了哈 还有两个小问题哈 第一个一旦按下T阿能先把曲线处理成闭合的(有时候曲线虽然首尾 ...
测量曲线上两点间的路程长度.
(defun C:qjcd (/ entName1 Pt1 Pt2 xLen st_pt end_pt pt_tmp l_ss PD pd1 obj)
(vl-load-com)
(setq entName1 (car (entselEx"\r请选择直线、圆弧、圆、多段线等曲线:" '((0 . "line,arc,circle,lwpolyline")))))
(setq obj (vlax-ename->vla-object entName1))
(setq PD (< (distance (vlax-curve-getStartPoint obj) (vlax-curve-getEndPoint obj)) 0.0001))
(setq pt1 (getpoint "\n指定测量起点: ")
pt2 (getpoint "\n指定测量终点: ")
)
(setq
st_pt (vlax-curve-getStartPoint entName1)
end_pt (vlax-curve-getEndPoint entName1)
)
(setq entName2 entName1)
(if (>(vlax-curve-getParamAtPoint entName1 pt1) (vlax-curve-getParamAtPoint entName1 pt2))
(setq pt_tmp pt2
pt2 pt1
pt1 pt_tmp)
)
(vl-cmdf "undo" "be")
(vl-cmdf "_break" entName1 st_pt pt1)
(vl-cmdf "_break" entName1 end_pt pt2)
(vl-cmdf ".copy" entName1 "" '(0 0) '(0 0))
(setq l_ss (entget (entlast)))
(vl-cmdf "undo" "end")
(vl-cmdf "undo" "")
(entmake l_ss)
(setq entName1 (entlast))
(vla-put-Color (vlax-ename->vla-object entName1) 1)
(redraw entName1 3)
(initget 1 "T")
(setq pd1 (getstring "\n[取反向距离(T)]: ") )
(if (AND (or (= pd1 "t") (= pd1 "T")) PD)
(setq xLen (- (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj)) (abs (- (vlax-curve-getDistAtPoint entName1 pt1)(vlax-curve-getDistAtPoint entName1 pt2)))))
(setq xLen (abs (- (vlax-curve-getDistAtPoint entName1 pt1)(vlax-curve-getDistAtPoint entName1 pt2))))
)
(if (AND (or (= pd1 "t") (= pd1 "T")) PD)
(progn
(vl-cmdf "_erase"entName1 "")
(if (>(vlax-curve-getParamAtPoint entName2 pt1) (vlax-curve-getParamAtPoint entName2 pt2))
(setq pt_tmp pt2
pt2 pt1
pt1 pt_tmp)
)
(vl-cmdf "undo" "be")
(vl-cmdf "_break" entName2PT1 pt2 )
;(vl-cmdf "_break" entName1end_ptpt1)
(vl-cmdf ".copy" entName2 "" '(0 0) '(0 0))
(setq l_ss (entget (entlast)))
(vl-cmdf "undo" "end")
(vl-cmdf "undo" "")
(entmake l_ss)
(setq entName2 (entlast))
(vla-put-Color (vlax-ename->vla-object entName2) 1)
(redraw entName2 3)
(vl-cmdf "_erase"entName2)
)
)
(vl-cmdf "_erase"entName1"")
(princ (strcat "\n测量结果:两点间曲线长度=" (rtos xLen 2 2)))
;(princ "\n路径检查:查看亮显区域,右键退出")
(princ)
)
;;功能:带提示、关键字、过滤表、选择错误时的提示并且会亮显所选对像的entsel
;;用法:(entselEx提示信息 过滤表)
;;举例:(entselEx"\r请选择一个圆:" '((0 . "circle")) )
(defun entselEx (msg fil / el ss)
(while (and (setvar "errno" 0)
(not (and (setq el(entsel msg))
(if (= (type el) 'str)
el
(if (setq ss (ssget (cadr el) fil))
ss
(progn (princ ermsg) (setq ss nil))
);if
);if
);and
);not
(/= (getvar "errno") 52)
);and
);while
(if (= (type el) 'list) (redraw (car el) 3));亮显选中的对像
el
)
这个是右键直接退出,,至于你说的线先闭合,,这个要有个多少范围距离让它自动闭合,,你主要的是什么类型的线??圆还是多段线?? yaojing38 发表于 2023-6-12 13:53
测量曲线上两点间的路程长度.
(defun C:qjcd (/ entName1 Pt1 Pt2 xLen st_pt end_pt pt_tmp l_ss PD pd ...
特指看起来首尾相连,实际没有闭合的多段线,我想着这样应该处理起来比较简单/多段线特性里的闭合选择是就行了哈 15062311027 发表于 2023-6-12 16:32
特指看起来首尾相连,实际没有闭合的多段线,我想着这样应该处理起来比较简单/多段线特性里的闭合选择是 ...
;测量曲线上两点间的路程长度.
(defun C:qjcd (/ entName1 Pt1 Pt2 xLen st_pt end_pt pt_tmp l_ss PD pd1 obj)
(vl-load-com)
(setq entName1 (car (entselEx"\r请选择直线、圆弧、圆、多段线等曲线:" '((0 . "line,arc,circle,lwpolyline")))))
(if (= (assoc 0 (entget entName1) ) "LWPOLYLINE") (MakeTrueClosePL entName1))
(setq obj (vlax-ename->vla-object entName1))
(setq PD (< (distance (vlax-curve-getStartPoint obj) (vlax-curve-getEndPoint obj)) 0.0001))
(setq pt1 (getpoint "\n指定测量起点: ")
pt2 (getpoint "\n指定测量终点: ")
)
(setq
st_pt (vlax-curve-getStartPoint entName1)
end_pt (vlax-curve-getEndPoint entName1)
)
(setq entName2 entName1)
(if (>(vlax-curve-getParamAtPoint entName1 pt1) (vlax-curve-getParamAtPoint entName1 pt2))
(setq pt_tmp pt2
pt2 pt1
pt1 pt_tmp)
)
(vl-cmdf "undo" "be")
(vl-cmdf "_break" entName1 st_pt pt1)
(vl-cmdf "_break" entName1 end_pt pt2)
(vl-cmdf ".copy" entName1 "" '(0 0) '(0 0))
(setq l_ss (entget (entlast)))
(vl-cmdf "undo" "end")
(vl-cmdf "undo" "")
(entmake l_ss)
(setq entName1 (entlast))
(vla-put-Color (vlax-ename->vla-object entName1) 1)
(redraw entName1 3)
(initget 1 "T")
(setq pd1 (getstring "\n[取反向距离(T)]: ") )
(if (AND (or (= pd1 "t") (= pd1 "T")) PD)
(setq xLen (- (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj)) (abs (- (vlax-curve-getDistAtPoint entName1 pt1)(vlax-curve-getDistAtPoint entName1 pt2)))))
(setq xLen (abs (- (vlax-curve-getDistAtPoint entName1 pt1)(vlax-curve-getDistAtPoint entName1 pt2))))
)
(if (AND (or (= pd1 "t") (= pd1 "T")) PD)
(progn
(vl-cmdf "_erase"entName1 "")
(if (>(vlax-curve-getParamAtPoint entName2 pt1) (vlax-curve-getParamAtPoint entName2 pt2))
(setq pt_tmp pt2
pt2 pt1
pt1 pt_tmp)
)
(vl-cmdf "undo" "be")
(vl-cmdf "_break" entName2PT1 pt2 )
;(vl-cmdf "_break" entName1end_ptpt1)
(vl-cmdf ".copy" entName2 "" '(0 0) '(0 0))
(setq l_ss (entget (entlast)))
(vl-cmdf "undo" "end")
(vl-cmdf "undo" "")
(entmake l_ss)
(setq entName2 (entlast))
(vla-put-Color (vlax-ename->vla-object entName2) 1)
(redraw entName2 3)
(vl-cmdf "_erase"entName2)
)
)
(vl-cmdf "_erase"entName1"")
(princ (strcat "\n测量结果:两点间曲线长度=" (rtos xLen 2 2)))
;(princ "\n路径检查:查看亮显区域,右键退出")
(princ)
)
;;功能:带提示、关键字、过滤表、选择错误时的提示并且会亮显所选对像的entsel
;;用法:(entselEx提示信息 过滤表)
;;举例:(entselEx"\r请选择一个圆:" '((0 . "circle")) )
(defun entselEx (msg fil / el ss)
(while (and (setvar "errno" 0)
(not (and (setq el(entsel msg))
(if (= (type el) 'str)
el
(if (setq ss (ssget (cadr el) fil))
ss
(progn (princ ermsg) (setq ss nil))
);if
);if
);and
);not
(/= (getvar "errno") 52)
);and
);while
(if (= (type el) 'list) (redraw (car el) 3));亮显选中的对像
el
)
;;164.56 [功能] 使多段线真闭合
;;(MakeTrueClosePL (car(entsel)))对于非输入C闭合的
(defun MakeTrueClosePL (e / EN L L1 LST X)
(setq en (entget e))
(while (setq x(car en)
en (cdr en)
)
(cond
((and (/= (car x) 10) (or (not L) (not L1))) (setq Lst (cons x Lst)))
((equal (car x) 10) (setq L1 (cons L L1)) (setq L nil) (setq L (cons x L)))
(T (setq L (cons x L)))
)
)
(setq lst (reverse lst))
(setq lst (subst '(70 . 1) (assoc 70 lst) lst))
(setq lst (subst (cons 90 (1- (cdr (assoc 90 lst)))) (assoc 90 lst) lst))
(setq L1 (apply 'append (reverse (mapcar 'reverse L1))))
(entmod (append lst L1 (list x)))
)
改了下,,你再试下
yaojing38 发表于 2023-6-12 17:14
;测量曲线上两点间的路程长度.
(defun C:qjcd (/ entName1 Pt1 Pt2 xLen st_pt end_pt pt_tmp l_ss PD p ...
你好 应该处理闭合没有成功 只要没闭合,按T时,只能选择已选择段落两侧的其中一段/另开始选择正确时,右键是右键菜单,点确认才行 不是直接右键就行的 15062311027 发表于 2023-6-12 18:25
你好 应该处理闭合没有成功 只要没闭合,按T时,只能选择已选择段落两侧的其中一段/另开始选择正确时,右 ...
右键你工具自定义右键单击,,改一下右键为确定就行,,,闭合的要不你发个图上来我看下是怎么回事?
页:
[1]
2