直线、多段线(不含圆弧段)长度增量工具

fangmin723

效果如图所示：


系统自带的命令：

命令: LENGTHEN
选择对象或 [增量(DE)/百分数(P)/全部(T)/动态(DY)]: DE
输入长度增量或 [角度(A)] <0.00>:

1. ;;说明:直线、多段线(不含圆弧段)长度增量工具
   
2. (defun c:CDE(/ arcang arcinfo arclength bulge cenpt eang ent ept exang exdis getptlength isstoe istype lm:bulge->arc modpt nearpt obj oldlen param ptlen radius sang spt ss var)
   
3.   (vl-load-com)
   
4.   ;; Bulge to Arc  -  Lee Mac
   
5.   ;; p1 - start vertex
   
6.   ;; p2 - end vertex
   
7.   ;; b  - bulge
   
8.   ;; Returns: (<center> <start angle> <end angle> <radius>)
   
9.   (defun LM:Bulge->Arc ( p1 p2 b / c r )
   
10.     (setq r (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
    
11.       c (polar p1 (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b)))) r)
    
12.     )
    
13.     (if (minusp b)
    
14.       (list c (angle c p2) (angle c p1) (abs r))
    
15.       (list c (angle c p1) (angle c p2) (abs r))
    
16.     )
    
17.   )
    
18.   (defun getptlength(lsobj lsparam / lsspt lsept)
    
19.     (list
    
20.       (setq lsspt (vlax-curve-getPointAtParam lsobj lsparam))
    
21.       (setq lsept (vlax-curve-getPointAtParam lsobj (1+ lsparam)))
    
22.       (distance lsspt lsept)
    
23.     )
    
24.   )
    
25.   (while (and (setq exdis (getdist (strcat "\n输入增量:"))) (/= exdis 0))
    
26.     (while
    
27.       (setq ss
    
28.         (ssget ":S"
    
29.           '(
    
30.              (-4 . "<or")
    
31.              (0 . "LINE")
    
32.              (-4 . "<and")
    
33.              (0 . "LWPOLYLINE")
    
34.              (-4 . "!=") (70 . 1)
    
35.              (-4 . "and>")
    
36.              (-4 . "or>")
    
37.            )
    
38.         )
    
39.       )
    
40.       (setq ent (ssnamex ss 0) istype (cdr (assoc 0 (entget (cadar ent)))))
    
41.       (setq obj (vlax-ename->vla-object (cadar ent)))
    
42.       (setq nearpt (vlax-curve-getClosestPointTo obj (cadr (last (car ent))) t))
    
43.       (if (equal istype "LWPOLYLINE")
    
44.         (progn
    
45.           (setq param (fix (vlax-curve-getParamAtPoint obj nearpt)))
    
46.           (setq ptlen (getptlength obj param) spt (car ptlen) ept (cadr ptlen) oldlen (caddr ptlen))
    
47.           (setq bulge (vla-GetBulge obj param))
    
48.           (if (= bulge 0)
    
49.             (progn
    
50.               (setq isstoe (> (distance spt nearpt) (distance ept nearpt)))
    
51.               (setq modpt (polar (if isstoe ept spt) (if isstoe (angle spt ept) (angle ept spt)) exdis))
    
52.               (setq var (vlax-make-safearray vlax-vbDouble '(0 . 1)))
    
53.               (vlax-safearray-fill var (list (car modpt) (cadr modpt)))
    
54.               (vla-put-Coordinate obj (if isstoe (+ 1 param) (+ 0 param)) var)
    
55.               (vla-Update obj)
    
56.               (princ (strcat "\n原始线段长【" (rtos oldlen) "】, 增量【" (rtos exdis) "】, 当前线段长【" (rtos (caddr (getptlength obj param))) "】"))
    
57.             )
    
58.             (progn
    
59.             ;  (setq arcinfo (LM:Bulge->Arc spt ept bulge) cenpt (car arcinfo) sang (cadr arcinfo) eang (caddr arcinfo) radius (cadddr arcinfo))
    
60.             ;  (setq arclength (- (vlax-curve-getDistAtParam obj (1+ param)) (vlax-curve-getDistAtParam obj param)))
    
61.             ;  (setq arcang (/ arclength radius))
    
62.             ;  (setq exang (/ exdis radius))
    
63.             ;  (if (or (and (> exang 0) (< (+ exang arcang) (* pi 2))) (and (< exang 0) (< (abs exang) arcang)))
    
64.             ;    (progn
    
65.             ;      (setq isstoe (> (distance spt nearpt) (distance ept nearpt)))
    
66.             ;      (setq modpt (polar cenpt (if isstoe (+ eang exang) (- sang exang)) radius))
    
67.             ;      (setq var (vlax-make-safearray vlax-vbDouble '(0 . 1)))
    
68.             ;      (vlax-safearray-fill var (list (car modpt) (cadr modpt)))
    
69.             ;      (vla-put-Coordinate obj (if isstoe (+ 1 param) (+ 0 param)) var)
    
70.             ;      (vla-Update obj)
    
71.             ;    )
    
72.             ;  )
    
73.             )
    
74.           )
    
75.         )
    
76.         (progn
    
77.           (setq spt (vlax-curve-getStartPoint obj))
    
78.           (setq ept (vlax-curve-getEndPoint obj))
    
79.           (setq isstoe (> (distance spt nearpt) (distance ept nearpt)))
    
80.           (setq modpt (polar (if isstoe ept spt) (if isstoe (angle spt ept) (angle ept spt)) exdis))
    
81.           (if isstoe (vla-put-EndPoint obj (vlax-3D-point modpt)) (vla-put-StartPoint obj (vlax-3D-point modpt)))
    
82.           (vla-Update obj)
    
83.           (princ (strcat "\n原始线段长【" (rtos (distance spt ept)) "】, 增量【" (rtos exdis) "】, 当前线段长【" (rtos (distance (vlax-curve-getStartPoint obj) (vlax-curve-getEndPoint obj))) "】"))
    
84.         )
    
85.       )
    
86.     )
    
87.   )
    
88.   (prin1)
    
89. )

;;说明:直线、多段线(不含圆弧段)长度增量<a href="http://bbs.mjtd.com/forum-6-1.html" target="_blank" class="relatedlink">工具</a><br /> (defun c:CDE(/ arcang arcinfo arclength bulge cenpt eang ent ept exang exdis getptlength isstoe istype lm:bulge->arc modpt nearpt obj oldlen param ptlen radius sang spt ss var)<br />   (vl-load-com)<br />   ;; Bulge to Arc  -  Lee Mac<br />   ;; p1 - start vertex<br />   ;; p2 - end vertex<br />   ;; b  - bulge<br />   ;; Returns: (<center> <start angle> <end angle> <radius>)<br />   (defun LM:Bulge->Arc ( p1 p2 b / c r )<br />     (setq r (/ (* (distance p1 p2) (1+ (* b b))) 4 b)<br />       c (polar p1 (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b)))) r)<br />     )<br />     (if (minusp b)<br />       (list c (angle c p2) (angle c p1) (abs r))<br />       (list c (angle c p1) (angle c p2) (abs r))<br />     )<br />   )<br />   (defun getptlength(lsobj lsparam / lsspt lsept)<br />     (list<br />       (setq lsspt (vlax-curve-getPointAtParam lsobj lsparam))<br />       (setq lsept (vlax-curve-getPointAtParam lsobj (1+ lsparam)))<br />       (distance lsspt lsept)<br />     )<br />   )<br />   (while (and (setq exdis (getdist (strcat "\n输入增量:"))) (/= exdis 0))<br />     (while<br />       (setq ss<br />         (ssget ":S"<br />           '(<br />              (-4 . "<or")<br />              (0 . "LINE") <br />              (-4 . "<and")<br />              (0 . "LWPOLYLINE")<br />              (-4 . "!=") (70 . 1)<br />              (-4 . "and>")<br />              (-4 . "or>")<br />            )<br />         )<br />       )<br />       (setq ent (ssnamex ss 0) istype (cdr (assoc 0 (entget (cadar ent)))))<br />       (setq obj (vlax-ename->vla-object (cadar ent)))<br />       (setq nearpt (vlax-curve-getClosestPointTo obj (cadr (last (car ent))) t))<br />       (if (equal istype "LWPOLYLINE")<br />         (progn<br />           (setq param (fix (vlax-curve-getParamAtPoint obj nearpt)))<br />           (setq ptlen (getptlength obj param) spt (car ptlen) ept (cadr ptlen) oldlen (caddr ptlen))<br />           (setq bulge (vla-GetBulge obj param))<br />           (if (= bulge 0)<br />             (progn<br />               (setq isstoe (> (distance spt nearpt) (distance ept nearpt)))<br />               (setq modpt (polar (if isstoe ept spt) (if isstoe (angle spt ept) (angle ept spt)) exdis))<br />               (setq var (vlax-make-safearray vlax-vbDouble '(0 . 1)))<br />               (vlax-safearray-fill var (list (car modpt) (cadr modpt)))<br />               (vla-put-Coordinate obj (if isstoe (+ 1 param) (+ 0 param)) var)<br />               (vla-Update obj)<br />               (princ (strcat "\n原始线段长【" (rtos oldlen) "】, 增量【" (rtos exdis) "】, 当前线段长【" (rtos (caddr (getptlength obj param))) "】"))<br />             )<br />             (progn<br />             ;  (setq arcinfo (LM:Bulge->Arc spt ept bulge) cenpt (car arcinfo) sang (cadr arcinfo) eang (caddr arcinfo) radius (cadddr arcinfo))<br />             ;  (setq arclength (- (vlax-curve-getDistAtParam obj (1+ param)) (vlax-curve-getDistAtParam obj param)))<br />             ;  (setq arcang (/ arclength radius))<br />             ;  (setq exang (/ exdis radius))<br />             ;  (if (or (and (> exang 0) (< (+ exang arcang) (* pi 2))) (and (< exang 0) (< (abs exang) arcang)))<br />             ;    (progn<br />             ;      (setq isstoe (> (distance spt nearpt) (distance ept nearpt)))<br />             ;      (setq modpt (polar cenpt (if isstoe (+ eang exang) (- sang exang)) radius))<br />             ;      (setq var (vlax-make-safearray vlax-vbDouble '(0 . 1)))<br />             ;      (vlax-safearray-fill var (list (car modpt) (cadr modpt)))<br />             ;      (vla-put-Coordinate obj (if isstoe (+ 1 param) (+ 0 param)) var)<br />             ;      (vla-Update obj)<br />             ;    )<br />             ;  )<br />             )<br />           )<br />         )<br />         (progn<br />           (setq spt (vlax-curve-getStartPoint obj))<br />           (setq ept (vlax-curve-getEndPoint obj))<br />           (setq isstoe (> (distance spt nearpt) (distance ept nearpt)))<br />           (setq modpt (polar (if isstoe ept spt) (if isstoe (angle spt ept) (angle ept spt)) exdis))<br />           (if isstoe (vla-put-EndPoint obj (vlax-3D-point modpt)) (vla-put-StartPoint obj (vlax-3D-point modpt)))<br />           (vla-Update obj)<br />           (princ (strcat "\n原始线段长【" (rtos (distance spt ept)) "】, 增量【" (rtos exdis) "】, 当前线段长【" (rtos (distance (vlax-curve-getStartPoint obj) (vlax-curve-getEndPoint obj))) "】"))<br />         )<br />       )<br />     )<br />   )<br />   (prin1)<br /> )

针对于圆弧段还有待完善，有兴趣的话，你们可以自己试着去完善！！！

xyp1964

与 LENGTHEN功能有啥区别？

fangmin723

yegucheng0129 发表于 2025-3-15 17:35
很实用的功能 ,感谢大佬分享,这个功能贱人工具箱里有,叫定距延长,另外你说的圆弧未完善,可以请教贱人大佬

我试了下贱人工具箱的定距延长，还是和我的预想有差别，我这个支持多段线子段定距延长，贱人工具箱中的延长只能延长多段线两端

xyp1964

fangmin723 发表于 2025-3-16 23:09
没有具体的区别，功能实现一样，比系统的简化了一步

line和arc可以直接用lengthen命令的De选项，lwpolyline可以单独处理

yegucheng0129

很实用的功能 ,感谢大佬分享,这个功能贱人工具箱里有,叫定距延长,另外你说的圆弧未完善,可以请教贱人大佬

hubeiwdlue

很强大，我们一般就用系统自带的那个，好像只针对多段线。

jkop

很特别的工具，直接拿来量测和分等好用！

fangmin723

xyp1964 发表于 2025-3-16 11:06
与 LENGTHEN功能有啥区别？

没有具体的区别，功能实现一样，比系统的简化了一步

fangmin723

xyp1964 发表于 2025-3-17 09:01
line和arc可以直接用lengthen命令的De选项，lwpolyline可以单独处理

嗯嗯，可以的，看个人需要了，想用哪种用哪种

xyp1964

多段线圆弧段的伸缩