直线、多段线(不含圆弧段)长度增量工具
效果如图所示：
系统自带的命令：
命令: LENGTHEN
选择对象或 [增量(DE)/百分数(P)/全部(T)/动态(DY)]: DE
输入长度增量或 [角度(A)] <0.00>:
;;说明:直线、多段线(不含圆弧段)长度增量工具
(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)
(vl-load-com)
;; Bulge to Arc-Lee Mac
;; p1 - start vertex
;; p2 - end vertex
;; b- bulge
;; Returns: (<center> <start angle> <end angle> <radius>)
(defun LM:Bulge->Arc ( p1 p2 b / c r )
(setq r (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
c (polar p1 (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b)))) r)
)
(if (minusp b)
(list c (angle c p2) (angle c p1) (abs r))
(list c (angle c p1) (angle c p2) (abs r))
)
)
(defun getptlength(lsobj lsparam / lsspt lsept)
(list
(setq lsspt (vlax-curve-getPointAtParam lsobj lsparam))
(setq lsept (vlax-curve-getPointAtParam lsobj (1+ lsparam)))
(distance lsspt lsept)
)
)
(while (and (setq exdis (getdist (strcat "\n输入增量:"))) (/= exdis 0))
(while
(setq ss
(ssget ":S"
'(
(-4 . "<or")
(0 . "LINE")
(-4 . "<and")
(0 . "LWPOLYLINE")
(-4 . "!=") (70 . 1)
(-4 . "and>")
(-4 . "or>")
)
)
)
(setq ent (ssnamex ss 0) istype (cdr (assoc 0 (entget (cadar ent)))))
(setq obj (vlax-ename->vla-object (cadar ent)))
(setq nearpt (vlax-curve-getClosestPointTo obj (cadr (last (car ent))) t))
(if (equal istype "LWPOLYLINE")
(progn
(setq param (fix (vlax-curve-getParamAtPoint obj nearpt)))
(setq ptlen (getptlength obj param) spt (car ptlen) ept (cadr ptlen) oldlen (caddr ptlen))
(setq bulge (vla-GetBulge obj param))
(if (= bulge 0)
(progn
(setq isstoe (> (distance spt nearpt) (distance ept nearpt)))
(setq modpt (polar (if isstoe ept spt) (if isstoe (angle spt ept) (angle ept spt)) exdis))
(setq var (vlax-make-safearray vlax-vbDouble '(0 . 1)))
(vlax-safearray-fill var (list (car modpt) (cadr modpt)))
(vla-put-Coordinate obj (if isstoe (+ 1 param) (+ 0 param)) var)
(vla-Update obj)
(princ (strcat "\n原始线段长【" (rtos oldlen) "】, 增量【" (rtos exdis) "】, 当前线段长【" (rtos (caddr (getptlength obj param))) "】"))
)
(progn
;(setq arcinfo (LM:Bulge->Arc spt ept bulge) cenpt (car arcinfo) sang (cadr arcinfo) eang (caddr arcinfo) radius (cadddr arcinfo))
;(setq arclength (- (vlax-curve-getDistAtParam obj (1+ param)) (vlax-curve-getDistAtParam obj param)))
;(setq arcang (/ arclength radius))
;(setq exang (/ exdis radius))
;(if (or (and (> exang 0) (< (+ exang arcang) (* pi 2))) (and (< exang 0) (< (abs exang) arcang)))
; (progn
; (setq isstoe (> (distance spt nearpt) (distance ept nearpt)))
; (setq modpt (polar cenpt (if isstoe (+ eang exang) (- sang exang)) radius))
; (setq var (vlax-make-safearray vlax-vbDouble '(0 . 1)))
; (vlax-safearray-fill var (list (car modpt) (cadr modpt)))
; (vla-put-Coordinate obj (if isstoe (+ 1 param) (+ 0 param)) var)
; (vla-Update obj)
; )
;)
)
)
)
(progn
(setq spt (vlax-curve-getStartPoint obj))
(setq ept (vlax-curve-getEndPoint obj))
(setq isstoe (> (distance spt nearpt) (distance ept nearpt)))
(setq modpt (polar (if isstoe ept spt) (if isstoe (angle spt ept) (angle ept spt)) exdis))
(if isstoe (vla-put-EndPoint obj (vlax-3D-point modpt)) (vla-put-StartPoint obj (vlax-3D-point modpt)))
(vla-Update obj)
(princ (strcat "\n原始线段长【" (rtos (distance spt ept)) "】, 增量【" (rtos exdis) "】, 当前线段长【" (rtos (distance (vlax-curve-getStartPoint obj) (vlax-curve-getEndPoint obj))) "】"))
)
)
)
)
(prin1)
)
针对于圆弧段还有待完善，有兴趣的话，你们可以自己试着去完善！！！
与 LENGTHEN功能有啥区别？ 本帖最后由 fangmin723 于 2025-3-17 08:00 编辑
yegucheng0129 发表于 2025-3-15 17:35
很实用的功能 ,感谢大佬分享,这个功能贱人工具箱里有,叫定距延长,另外你说的圆弧未完善,可以请教贱人大佬
我试了下贱人工具箱的定距延长，还是和我的预想有差别，我这个支持多段线子段定距延长，贱人工具箱中的延长只能延长多段线两端 fangmin723 发表于 2025-3-16 23:09
没有具体的区别，功能实现一样，比系统的简化了一步
line和arc可以直接用lengthen命令的De选项，lwpolyline可以单独处理
很实用的功能 ,感谢大佬分享,这个功能贱人工具箱里有,叫定距延长,另外你说的圆弧未完善,可以请教贱人大佬 很强大，我们一般就用系统自带的那个，好像只针对多段线。 很特别的工具，直接拿来量测和分等好用！ xyp1964 发表于 2025-3-16 11:06
与 LENGTHEN功能有啥区别？
没有具体的区别，功能实现一样，比系统的简化了一步 xyp1964 发表于 2025-3-17 09:01
line和arc可以直接用lengthen命令的De选项，lwpolyline可以单独处理
嗯嗯，可以的，看个人需要了，想用哪种用哪种
多段线圆弧段的伸缩
页:
[1]
2