15062311027 发表于 2023-6-11 12:20:17

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

原代码是在论坛找的,感谢原作者,主要功能是点取曲线上两点,获取两点间距离,此次增加功能是对于首尾相连的曲线,有时候想获取的两点间的距离是和原插件获取的相反的部分的长度,请大声伸下援手哈,最好是直接按T键直接转换

yaojing38 发表于 2023-6-11 12:20:18

本帖最后由 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 ,提示取反不输入不取反

yaojing38 发表于 2023-6-11 22:11:49

;测量曲线上两点间的路程长度.
(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)
)

你试下行不行

15062311027 发表于 2023-6-11 22:33:19

yaojing38 发表于 2023-6-11 22:11
;测量曲线上两点间的路程长度.
(defun C:T (/ entName1 Pt1 Pt2 xLen st_pt end_pt pt_tmp l_ss PDobj)
...

你好 这么晚了还打扰你哈 现在提示错误: 输入的字符串有缺陷
还有我意思是比如截取两点间距离 ,发现亮显段就是自己需要的段落就直接右键结束,否则如果发现亮显段和实际要测的段落刚好相反 则直接按一个键T或者其他字母 就亮显反向的那段,且输出反向那段长度 麻烦再看下哈

15062311027 发表于 2023-6-12 09:00:30

yaojing38 发表于 2023-6-11 12:20
你用原来命令QJCD ,提示取反不输入不取反

你好 现在基本满足了哈 还有两个小问题哈 第一个一旦按下T阿能先把曲线处理成闭合的(有时候曲线虽然首尾相连,但不是闭合的,这种情形插件不能准确识别反向测量区域) 第二个如果一开始选择的曲线段落就符合要求,看能不能改成直接按右键出结果退出

yaojing38 发表于 2023-6-12 13:53:07

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
)
这个是右键直接退出,,至于你说的线先闭合,,这个要有个多少范围距离让它自动闭合,,你主要的是什么类型的线??圆还是多段线??

15062311027 发表于 2023-6-12 16:32:51

yaojing38 发表于 2023-6-12 13:53
测量曲线上两点间的路程长度.
(defun C:qjcd (/ entName1 Pt1 Pt2 xLen st_pt end_pt pt_tmp l_ss PD pd ...

特指看起来首尾相连,实际没有闭合的多段线,我想着这样应该处理起来比较简单/多段线特性里的闭合选择是就行了哈

yaojing38 发表于 2023-6-12 17:14:53

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)))
)

改了下,,你再试下

15062311027 发表于 2023-6-12 18:25:12

yaojing38 发表于 2023-6-12 17:14
;测量曲线上两点间的路程长度.
(defun C:qjcd (/ entName1 Pt1 Pt2 xLen st_pt end_pt pt_tmp l_ss PD p ...

你好 应该处理闭合没有成功 只要没闭合,按T时,只能选择已选择段落两侧的其中一段/另开始选择正确时,右键是右键菜单,点确认才行 不是直接右键就行的

yaojing38 发表于 2023-6-14 17:46:01

15062311027 发表于 2023-6-12 18:25
你好 应该处理闭合没有成功 只要没闭合,按T时,只能选择已选择段落两侧的其中一段/另开始选择正确时,右 ...

右键你工具自定义右键单击,,改一下右键为确定就行,,,闭合的要不你发个图上来我看下是怎么回事?
页: [1] 2
查看完整版本: 曲线局部长度插件反向改编