平分曲线(LISP免费插件)

hhh454

在论坛里看到的，可以学习借鉴一下，原址找不到了，没有版主的全面
功能：在两条曲线中间建立均分曲线
，可以复制，可以下载，一样的

1. ;---曲线按段数等分，返回点表
   
2. (defun div_n_crv(obj n / len mm pts)
   
3.   (setq len(vlax-curve-getdistatparam obj(vlax-curve-getendparam obj)))
   
4.   (setq mm(/ len n))
   
5.   (setq pts nil)
   
6.   (setq pts(cons(vlax-curve-getEndPoint obj)pts));终点加入到点表
   
7.   (while
   
8.     (>(setq len(- len mm))0.1)
   
9.     (setq pts(cons(vlax-curve-getPointAtDist obj len)pts))
   
10.   )
    
11.   (setq pts(cons(vlax-curve-getStartPoint obj)pts));起点加入到点表
    
12. )
    
13. (defun c:tween_curve(/ dis len1 len2 lenmax n obj1 obj2 pts1 pts2 pts3 pts5 tol)
    
14.   (setq obj1(vlax-ename->vla-object(car(entsel "\n请选取第一根曲线："))))
    
15.   (setq obj2(vlax-ename->vla-object(car(entsel "\n请选取第二根曲线："))))
    
16.   (setq n(getint "\n两条曲线中间均分创建几条曲线？<1>"))(or n(setq n 1))
    
17.   (if(not(and obj1 obj2 n))(quit));防呆措施
    
18.   (setq len1(vlax-curve-getdistatparam obj1(vlax-curve-getendparam obj1)))
    
19.   (setq len2(vlax-curve-getdistatparam obj2(vlax-curve-getendparam obj2)))
    
20.   (setq tol(fix(* 0.01(setq lenmax(max len1 len2)))))
    
21.   (setq dis(getreal(strcat "\n请设置等分近似值（以长线为准，短线适配，默认百分之一，越小越准确）：<"(rtos tol 2 0)">")))
    
22.   (or dis(setq dis tol))
    
23.   (setq pts1(div_n_crv obj1(fix(/ lenmax dis))))
    
24.   (setq pts2(div_n_crv obj2(fix(/ lenmax dis))))
    
25.   (if
    
26.     (>
    
27.       (distance(car pts1)(car pts2))
    
28.       (distance(car pts1)(last pts2))
    
29.     )
    
30.     (setq pts2(reverse pts2))
    
31.   )
    
32.   (setq pts3(mapcar '(lambda(x1 x2)
    
33.                        (setq dist(distance x1 x2))
    
34.                        (setq mm(/ dist(1+ n)))
    
35.                        (setq pts4 nil)
    
36.                        (while
    
37.                          (>(setq dist(- dist mm))0.1)
    
38.                          (setq pts4(cons(polar x1(angle x1 x2)dist)pts4))
    
39.                        )
    
40.                      )pts1 pts2))
    
41.   (setq pts5(apply 'mapcar(cons 'list pts3)))
    
42.   (foreach lst pts5
    
43.     (entmake(append
    
44.               (list
    
45.                 '(0 . "SPLINE")
    
46.                 '(100 . "AcDbEntity")
    
47.                 '(100 . "AcDbSpline")
    
48.                 '(71 . 3)
    
49.                 '(62 . 6)
    
50.               )
    
51.               (mapcar '(lambda(x)(cons 11 x))lst)
    
52.             )
    
53.     )
    
54.   )
    
55.   (princ)
    
56. )
    

;---曲线按段数等分，返回点表<br /> (defun div_n_crv(obj n / len mm pts)<br />   (setq len(vlax-curve-getdistatparam obj(vlax-curve-getendparam obj)))<br />   (setq mm(/ len n))<br />   (setq pts nil)<br />   (setq pts(cons(vlax-curve-getEndPoint obj)pts));终点加入到点表<br />   (while<br />     (>(setq len(- len mm))0.1)<br />     (setq pts(cons(vlax-curve-getPointAtDist obj len)pts))<br />   )<br />   (setq pts(cons(vlax-curve-getStartPoint obj)pts));起点加入到点表<br /> )<br /> (defun c:tween_curve(/ dis len1 len2 lenmax n obj1 obj2 pts1 pts2 pts3 pts5 tol)<br />   (setq obj1(vlax-ename->vla-object(car(entsel "\n请选取第一根曲线："))))<br />   (setq obj2(vlax-ename->vla-object(car(entsel "\n请选取第二根曲线："))))<br />   (setq n(getint "\n两条曲线中间均分创建几条曲线？<1>"))(or n(setq n 1))<br />   (if(not(and obj1 obj2 n))(quit));防呆措施<br />   (setq len1(vlax-curve-getdistatparam obj1(vlax-curve-getendparam obj1)))<br />   (setq len2(vlax-curve-getdistatparam obj2(vlax-curve-getendparam obj2)))<br />   (setq tol(fix(* 0.01(setq lenmax(max len1 len2)))))<br />   (setq dis(getreal(strcat "\n请设置等分近似值（以长线为准，短线适配，默认百分之一，越小越准确）：<"(rtos tol 2 0)">")))<br />   (or dis(setq dis tol))<br />   (setq pts1(div_n_crv obj1(fix(/ lenmax dis))))<br />   (setq pts2(div_n_crv obj2(fix(/ lenmax dis))))<br />   (if<br />     (><br />       (distance(car pts1)(car pts2))<br />       (distance(car pts1)(last pts2))<br />     )<br />     (setq pts2(reverse pts2))<br />   )<br />   (setq pts3(mapcar '(lambda(x1 x2)<br />                        (setq dist(distance x1 x2))<br />                        (setq mm(/ dist(1+ n)))<br />                        (setq pts4 nil)<br />                        (while<br />                          (>(setq dist(- dist mm))0.1)<br />                          (setq pts4(cons(polar x1(angle x1 x2)dist)pts4))<br />                        )<br />                      )pts1 pts2))<br />   (setq pts5(apply 'mapcar(cons 'list pts3)))<br />   (foreach lst pts5<br />     (entmake(append<br />               (list<br />                 '(0 . "SPLINE")<br />                 '(100 . "AcDbEntity")<br />                 '(100 . "AcDbSpline")<br />                 '(71 . 3)<br />                 '(62 . 6)<br />               )<br />               (mapcar '(lambda(x)(cons 11 x))lst)<br />             )<br />     )<br />   )<br />   (princ)<br /> )<br />

堇歌

谢谢分享，下载试试!!!!!

lxl217114

谢谢分享，这种2个线中线均分的功能，CAD居然一直没有吸纳进来。
犀牛是自带这种功能好久了

成仔

谢谢分享辛苦了楼主

jhzlx

感谢分享

biya

love1030312 发表于 2025-3-13 08:18
每个人的命令使用习惯不一样  太短会造成别人的重复  你要简单的可以自己自定义一下就可以了   版主是照 ...

正解，短了会冲突，到时用户骂声一片

biya

kexiya123 发表于 2025-3-13 08:03
提个简单要求，把运用的命令名字写简单一点，不要那么长

自己写一个引导文件就行，用短命令调用，再就是在PGP文件中写一个快捷键就行，那是官方自带功能

he520930

感谢分享，不用弄到犀牛里了

wangsr

谢谢分享辛苦了楼主

love1030312

kexiya123 发表于 2025-3-13 08:03
提个简单要求，把运用的命令名字写简单一点，不要那么长

每个人的命令使用习惯不一样  太短会造成别人的重复  你要简单的可以自己自定义一下就可以了   版主是照顾大家的使用