曲线局部长度插件反向改编

15062311027

yaojing38 发表于 2023-6-14 17:46
右键你工具自定义右键单击，，改一下  右键为确定就行，，，闭合的要不你发个图上来我看下是怎么回事？

麻烦看下哈

yaojing38

15062311027 发表于 2023-6-14 19:41
麻烦看下哈

2. ;测量曲线上两点间的路程长度.
   
3. (defun C:qjcd (/ entName1 Pt1 Pt2 xLen st_pt end_pt pt_tmp l_ss PD pd1 obj)
   
4.     (vl-load-com)
   
5.     (setq entName1 (car (entselEx  "\r请选择直线、圆弧、圆、多段线等曲线：" '((0 . "line,arc,circle,lwpolyline")))))
   
6.         (if (= (cdr (assoc 0 (entget entName1))) "LWPOLYLINE") (curve:putclosed entName1))
   
7.     (setq obj (vlax-ename->vla-object entName1))  
   
8.     (setq PD (< (distance (vlax-curve-getStartPoint obj) (vlax-curve-getEndPoint obj)) 0.0001))  
   
9.    
   
10.    
    
11.     (setq pt1 (getpoint "\n指定测量起点: ")
    
12.            pt2 (getpoint "\n指定测量终点: ")
    
13.          
    
14.     )
    
15.   
    
16.     (setq
    
17.             st_pt (vlax-curve-getStartPoint entName1)
    
18.             end_pt (vlax-curve-getEndPoint entName1)
    
19.     )
    
20.       (setq   entName2 entName1)
    
21.   
    
22.       
    
23.     (if (>  (vlax-curve-getParamAtPoint entName1 pt1) (vlax-curve-getParamAtPoint entName1 pt2))
    
24.           (setq pt_tmp pt2
    
25.                   pt2 pt1
    
26.                   pt1 pt_tmp)
    
27.            )
    
28.           (vl-cmdf "undo" "be")
    
29.           (vl-cmdf "_break" entName1 st_pt pt1)
    
30.           (vl-cmdf "_break" entName1 end_pt pt2)
    
31.           (vl-cmdf ".copy" entName1 "" '(0 0) '(0 0))
    
32.           (setq l_ss (entget (entlast)))
    
33.           (vl-cmdf "undo" "end")
    
34.           (vl-cmdf "undo" "")
    
35.           (entmake l_ss)
    
36.           (setq entName1 (entlast))
    
37.           (vla-put-Color (vlax-ename->vla-object entName1) 1)
    
38.           (redraw entName1 3)
    
39.           (initget 1 "T")  
    
40.           (setq pd1 (getstring "\n[取反向距离(T)]: ") )
    
41.           (if (AND (or (= pd1 "t") (= pd1 "T")) PD)
    
42.           (setq xLen (- (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj)) (abs (- (vlax-curve-getDistAtPoint entName1 pt1)(vlax-curve-getDistAtPoint entName1 pt2)))))
    
43.           (setq xLen (abs (- (vlax-curve-getDistAtPoint entName1 pt1)(vlax-curve-getDistAtPoint entName1 pt2))))
    
44.           )  
    
45.           (if (AND (or (= pd1 "t") (= pd1 "T")) PD)
    
46.           (progn
    
47.           (vl-cmdf "_erase"  entName1 "")
    
48.                 (if (>  (vlax-curve-getParamAtPoint entName2 pt1) (vlax-curve-getParamAtPoint entName2 pt2))
    
49.           (setq pt_tmp pt2
    
50.                   pt2 pt1
    
51.                   pt1 pt_tmp)
    
52.            )
    
53.           (vl-cmdf "undo" "be")
    
54.           (vl-cmdf "_break" entName2  PT1 pt2 )
    
55.           ;(vl-cmdf "_break" entName1  end_pt  pt1)
    
56.           (vl-cmdf ".copy" entName2 "" '(0 0) '(0 0))
    
57.           (setq l_ss (entget (entlast)))
    
58.           (vl-cmdf "undo" "end")
    
59.           (vl-cmdf "undo" "")
    
60.           (entmake l_ss)
    
61.           (setq entName2 (entlast))
    
62.           (vla-put-Color (vlax-ename->vla-object entName2) 1)
    
63.           (redraw entName2 3)
    
64.           (vl-cmdf "_erase"  entName2)
    
65.           )
    
66.           )
    
67.           (vl-cmdf "_erase"  entName1  "")
    
68.           (princ (strcat "\n测量结果:两点间曲线长度=" (rtos xLen 2 2)))
    
69.           ;(princ "\n路径检查:查看亮显区域,右键退出")
    
70. (princ)
    
71. )
    
72. 
    
73. ;;功能：带提示、关键字、过滤表、选择错误时的提示并且会亮显所选对像的entsel
    
74. ;;用法：(entselEx  提示信息 过滤表)
    
75. ;;举例：(entselEx  "\r请选择一个圆：" '((0 . "circle")) )
    
76. (defun entselEx (msg fil / el ss)
    
77.         (while (and (setvar "errno" 0)
    
78.                                          (not (and (setq el  (entsel msg))
    
79.                                                                         (if (= (type el) 'str)
    
80.                                                                                 el
    
81.                                                                                 (if (setq ss (ssget (cadr el) fil))
    
82.                                                                                         ss
    
83.                                                                                         (progn (princ ermsg) (setq ss nil))
    
84.                                                                                 );if
    
85.                                                                         );if
    
86.                                                                 );and
    
87.                                          );not
    
88.                                          (/= (getvar "errno") 52)
    
89.                                  );and
    
90.   );while
    
91.   (if (= (type el) 'list) (redraw (car el) 3));亮显选中的对像
    
92.   el
    
93. )
    
94. (defun curve:putclosed (obj)
    
95. ; "使多段线封闭"
    
96. ; "无"
    
97. ; "(curve:putClosed (car (entsel)))"
    
98.   (or (p:vlap obj)
    
99.     (setq obj (vlax-ename->vla-object obj)))
    
100.   (if (not (vlax-curve-isclosed obj))
     
101.     (vla-put-closed obj :vlax-true)))
     
102. 
     
103. (defun p:vlap (obj)
     
104. ; "判断是否vla对象."
     
105.   (equal (type obj)
     
106.     (quote vla-object)))

;测量曲线上两点间的路程长度.<br /> (defun C:qjcd (/ entName1 Pt1 Pt2 xLen st_pt end_pt pt_tmp l_ss PD pd1 obj)<br />     (vl-load-com)<br />     (setq entName1 (car (entselEx  "\r请选择直线、圆弧、圆、多段线等曲线：" '((0 . "line,arc,circle,lwpolyline")))))<br />         (if (= (cdr (assoc 0 (entget entName1))) "LWPOLYLINE") (curve:putclosed entName1))<br />     (setq obj (vlax-ename->vla-object entName1))  <br />     (setq PD (< (distance (vlax-curve-getStartPoint obj) (vlax-curve-getEndPoint obj)) 0.0001))  <br />    <br />    <br />     (setq pt1 (getpoint "\n指定测量起点: ")<br />            pt2 (getpoint "\n指定测量终点: ")<br />          <br />     )<br />   <br />     (setq<br />             st_pt (vlax-curve-getStartPoint entName1)<br />             end_pt (vlax-curve-getEndPoint entName1)<br />     )<br />       (setq   entName2 entName1)<br />   <br />       <br />     (if (>  (vlax-curve-getParamAtPoint entName1 pt1) (vlax-curve-getParamAtPoint entName1 pt2))<br />           (setq pt_tmp pt2<br />                   pt2 pt1<br />                   pt1 pt_tmp)<br />            )<br />           (vl-cmdf "undo" "be")<br />           (vl-cmdf "_break" entName1 st_pt pt1)<br />           (vl-cmdf "_break" entName1 end_pt pt2)<br />           (vl-cmdf ".copy" entName1 "" '(0 0) '(0 0))<br />           (setq l_ss (entget (entlast)))<br />           (vl-cmdf "undo" "end")<br />           (vl-cmdf "undo" "")<br />           (entmake l_ss)<br />           (setq entName1 (entlast))<br />           (vla-put-Color (vlax-ename->vla-object entName1) 1)<br />           (redraw entName1 3)<br />           (initget 1 "T")  <br />           (setq pd1 (getstring "\n[取反向距离(T)]: ") )<br />           (if (AND (or (= pd1 "t") (= pd1 "T")) PD)<br />           (setq xLen (- (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj)) (abs (- (vlax-curve-getDistAtPoint entName1 pt1)(vlax-curve-getDistAtPoint entName1 pt2)))))<br />           (setq xLen (abs (- (vlax-curve-getDistAtPoint entName1 pt1)(vlax-curve-getDistAtPoint entName1 pt2))))<br />           )  <br />           (if (AND (or (= pd1 "t") (= pd1 "T")) PD)<br />           (progn<br />           (vl-cmdf "_erase"  entName1 "")<br />                 (if (>  (vlax-curve-getParamAtPoint entName2 pt1) (vlax-curve-getParamAtPoint entName2 pt2))<br />           (setq pt_tmp pt2<br />                   pt2 pt1<br />                   pt1 pt_tmp)<br />            )<br />           (vl-cmdf "undo" "be")<br />           (vl-cmdf "_break" entName2  PT1 pt2 )<br />           ;(vl-cmdf "_break" entName1  end_pt  pt1)<br />           (vl-cmdf ".copy" entName2 "" '(0 0) '(0 0))<br />           (setq l_ss (entget (entlast)))<br />           (vl-cmdf "undo" "end")<br />           (vl-cmdf "undo" "")<br />           (entmake l_ss)<br />           (setq entName2 (entlast))<br />           (vla-put-Color (vlax-ename->vla-object entName2) 1)<br />           (redraw entName2 3)<br />           (vl-cmdf "_erase"  entName2)<br />           )<br />           )<br />           (vl-cmdf "_erase"  entName1  "")<br />           (princ (strcat "\n测量结果:两点间曲线长度=" (rtos xLen 2 2)))<br />           ;(princ "\n路径检查:查看亮显区域,右键退出")<br /> (princ)<br /> )<br /> <br /> ;;功能：带提示、关键字、过滤表、选择错误时的提示并且会亮显所选对像的entsel<br /> ;;用法：(entselEx  提示信息 过滤表)<br /> ;;举例：(entselEx  "\r请选择一个圆：" '((0 . "circle")) )<br /> (defun entselEx (msg fil / el ss)<br />         (while (and (setvar "errno" 0)<br />                                          (not (and (setq el  (entsel msg))<br />                                                                         (if (= (type el) 'str)<br />                                                                                 el<br />                                                                                 (if (setq ss (ssget (cadr el) fil))<br />                                                                                         ss<br />                                                                                         (progn (princ ermsg) (setq ss nil))<br />                                                                                 );if<br />                                                                         );if<br />                                                                 );and<br />                                          );not<br />                                          (/= (getvar "errno") 52)<br />                                  );and<br />   );while<br />   (if (= (type el) 'list) (redraw (car el) 3));亮显选中的对像<br />   el<br /> )<br /> (defun curve:putclosed (obj)<br /> ; "使多段线封闭"<br /> ; "无"<br /> ; "(curve:putClosed (car (entsel)))"<br />   (or (p:vlap obj)<br />     (setq obj (vlax-ename->vla-object obj)))<br />   (if (not (vlax-curve-isclosed obj))<br />     (vla-put-closed obj :vlax-true)))<br /> <br /> (defun p:vlap (obj)<br /> ; "判断是否vla对象."<br />   (equal (type obj)<br />     (quote vla-object)))

15062311027

yaojing38 发表于 2023-6-15 10:24

可以了 谢谢