指定直线或多段线的长度

hubeiwdlue

选择一条直线或多段线，输入长度，将修改直线或多段线端线段的长度为指定值。根据选择点到起点、终点距离判定修改的方向。

2. (defun c:tt (/ ang dxf en en-co en-qd ent en-zd index1 index2 newlength newpoint obj pt pt1 pt2 pt-nx pt-xg vb_new1 wdl_3d->2d)
   
3.   ;3维坐标转2维,chaoyin提供
   
4.   (defun wdl_3d->2d (L)
   
5.     (mapcar '+ L '(0.0 0.0))
   
6.   )
   
7.   ; main
   
8.   (setvar "cmdecho" 0)
   
9.   (command "_.undo" "_begin");;定义撤销开始处
   
10.   (if (and (setq en (entsel "\n选择一条直线或多段线: "))
    
11.         (setq ent (car en)
    
12.           pt (cadr en))
    
13.       )
    
14.     (progn
    
15.       (setq dxf (entget ent))
    
16.       (cond
    
17.         ((eq (cdr (assoc 0 dxf)) "LINE")
    
18.           (setq newLength (getreal "\n输入新的长度: "))
    
19.           (setq pt1 (wdl_3d->2d(cdr (assoc 10 dxf))) pt2 (wdl_3d->2d(cdr (assoc 11 dxf))))
    
20.           (if (> (distance pt1 pt) (distance pt2 pt))
    
21.             (progn
    
22.               (setq ang (angle pt1 pt2))
    
23.               (setq newPoint (polar pt1 ang newLength))
    
24.               (entmod (subst (cons 11 newPoint) (assoc 11 dxf) dxf))
    
25.             )
    
26.             (progn
    
27.               (setq ang (angle pt2 pt1))
    
28.               (setq newPoint (polar pt2 ang newLength))
    
29.               (entmod (subst (cons 10 newPoint) (assoc 10 dxf) dxf))
    
30.             )
    
31.           )
    
32.           (princ (strcat "\n长度已修改为 " (rtos newLength) "."))
    
33.         )
    
34.         ((eq (cdr (assoc 0 dxf)) "LWPOLYLINE")
    
35.           (setq newLength (getreal "\n输入新的长度: "))
    
36.           (setq obj (vlax-ename->vla-object ent))
    
37.           (setq en-co (cdr (assoc 90 dxf)))
    
38.           (setq en-qd (wdl_3d->2d(vlax-curve-getstartpoint ent)))
    
39.           (setq en-zd (wdl_3d->2d(vlax-curve-getendpoint ent)))
    
40.           ;确定需要修改的点
    
41.           (if (> (distance en-qd pt) (distance en-zd pt))
    
42.             (setq pt-xg en-zd)
    
43.             (setq pt-xg en-qd)
    
44.           )
    
45.           (setq index1 (fix (+ (vlax-curve-getParamAtPoint obj pt-xg) 0.1)))
    
46.           ;;获得相邻节点的编号和点坐标
    
47.           (setq index2 (1+ index1))
    
48.           (if (> index2 (1- en-co))
    
49.             (setq index2 (1- index1))
    
50.           )
    
51.           (setq pt-nx (vla-get-Coordinate obj index2))
    
52.           (setq pt-nx (vlax-safearray->list(vlax-variant-value pt-nx)))
    
53.           (setq ang (angle pt-nx pt-xg))
    
54.           (setq newPoint (polar pt-nx ang newLength))
    
55.           (setq vb_new1(vlax-safearray-fill(vlax-make-safearray vlax-vbdouble '(0 . 1)) newPoint))
    
56.           (vla-put-Coordinate obj index1  vb_new1)
    
57.           (princ (strcat "\n长度已修改为 " (rtos newLength) "."))
    
58.         )
    
59.       )
    
60.     )
    
61.     (princ "\n未选择图元。")
    
62.   )
    
63.   (command "_.undo" "_end");;定义撤销结束处
    
64.   (setvar "cmdecho" 1)
    
65.   (princ)
    
66. )

(defun c:tt (/ ang dxf en en-co en-qd ent en-zd index1 index2 newlength newpoint obj pt pt1 pt2 pt-nx pt-xg vb_new1 wdl_3d->2d)<br />   ;3维坐标转2维,chaoyin提供<br />   (defun wdl_3d->2d (L)<br />     (mapcar '+ L '(0.0 0.0))<br />   )<br />   ; main<br />   (setvar "cmdecho" 0)<br />   (command "_.undo" "_begin");;定义撤销开始处<br />   (if (and (setq en (entsel "\n选择一条直线或多段线: "))<br />         (setq ent (car en)<br />           pt (cadr en))<br />       ) <br />     (progn <br />       (setq dxf (entget ent))<br />       (cond <br />         ((eq (cdr (assoc 0 dxf)) "LINE")<br />           (setq newLength (getreal "\n输入新的长度: "))<br />           (setq pt1 (wdl_3d->2d(cdr (assoc 10 dxf))) pt2 (wdl_3d->2d(cdr (assoc 11 dxf))))<br />           (if (> (distance pt1 pt) (distance pt2 pt))<br />             (progn <br />               (setq ang (angle pt1 pt2))<br />               (setq newPoint (polar pt1 ang newLength))<br />               (entmod (subst (cons 11 newPoint) (assoc 11 dxf) dxf))<br />             )<br />             (progn <br />               (setq ang (angle pt2 pt1))<br />               (setq newPoint (polar pt2 ang newLength))<br />               (entmod (subst (cons 10 newPoint) (assoc 10 dxf) dxf))<br />             )<br />           )<br />           (princ (strcat "\n长度已修改为 " (rtos newLength) "."))<br />         )<br />         ((eq (cdr (assoc 0 dxf)) "LWPOLYLINE")<br />           (setq newLength (getreal "\n输入新的长度: "))<br />           (setq obj (vlax-ename->vla-object ent))<br />           (setq en-co (cdr (assoc 90 dxf)))<br />           (setq en-qd (wdl_3d->2d(vlax-curve-getstartpoint ent)))<br />           (setq en-zd (wdl_3d->2d(vlax-curve-getendpoint ent)))<br />           ;确定需要修改的点<br />           (if (> (distance en-qd pt) (distance en-zd pt))<br />             (setq pt-xg en-zd)<br />             (setq pt-xg en-qd)<br />           )<br />           (setq index1 (fix (+ (vlax-curve-getParamAtPoint obj pt-xg) 0.1)))<br />           ;;获得相邻节点的编号和点坐标<br />           (setq index2 (1+ index1))<br />           (if (> index2 (1- en-co))<br />             (setq index2 (1- index1))<br />           )<br />           (setq pt-nx (vla-get-Coordinate obj index2))<br />           (setq pt-nx (vlax-safearray->list(vlax-variant-value pt-nx)))<br />           (setq ang (angle pt-nx pt-xg))<br />           (setq newPoint (polar pt-nx ang newLength))<br />           (setq vb_new1(vlax-safearray-fill(vlax-make-safearray vlax-vbdouble '(0 . 1)) newPoint))<br />           (vla-put-Coordinate obj index1  vb_new1)<br />           (princ (strcat "\n长度已修改为 " (rtos newLength) "."))<br />         )<br />       )<br />     )<br />     (princ "\n未选择图元。")<br />   )<br />   (command "_.undo" "_end");;定义撤销结束处<br />   (setvar "cmdecho" 1)<br />   (princ)<br /> )

hnzx

chdxllll

试用了一下，还是好用，想用到平交口进出道渠化标线上，能否增加一下功能。
1、以固定长度打断点，线均留下。目前这个是其他线是删除，仅留固定长度的线。
2、可以一次选择多根线。

fangmin723

(COMMAND "LENGTHEN" "T" (getdist "\n输入新的长度: "))

hubeiwdlue

fangmin723 发表于 2026-1-12 07:46
(COMMAND "LENGTHEN" "T" (getdist "\n输入新的长度: "))

command这个命令没用过。

hubeiwdlue

chdxllll 发表于 2026-1-11 15:52
试用了一下，还是好用，想用到平交口进出道渠化标线上，能否增加一下功能。
1、以固定长度打断点，线均留 ...

1.第一个问题应该比较简单，端点A的坐标修改为B点，A点B点的坐标我们是知道的，新生成一个多段线就可以了，生成前加一个判断语句就好。我不是路线专业的，具体功能你自己会清楚些。
2.一个直线或线段有两个端点，修改哪个点的坐标，这个代码很难判断，这个问题不解决，多选就会出错。

fangmin723

chdxllll 发表于 2026-1-11 15:52
试用了一下，还是好用，想用到平交口进出道渠化标线上，能否增加一下功能。
1、以固定长度打断点，线均留 ...

是我这演示的效果吗

chdxllll

不用分这么多段，一般标线均分成2段，进道口靠近路口的留出固定长度的实线（例如留50米实线），路段上的正常的标线样式。
点选实线哪段就是留实线的一端。

参照下图就好理解点了。

hubeiwdlue

chdxllll 发表于 2026-1-12 12:25
不用分这么多段，一般标线均分成2段，进道口靠近路口的留出固定长度的实线（例如留50米实线），路段上的正 ...

是这个意思吗？

2. (defun c:tt()
   
3.         (setq en (entsel))
   
4.         (setq ent (car en)
   
5.                 pt (cadr en))
   
6.         (setq dxf (entget ent))
   
7.         (setq pt1 (cdr (assoc 10 dxf)) pt2 (cdr (assoc 11 dxf)))
   
8.         (setq len (getreal))
   
9.         (if (> (distance pt1 pt) (distance pt2 pt))
   
10.                 (progn
    
11.                         (setq ang (angle pt2 pt1))
    
12.                         (setq newPoint (polar pt2 ang len))
    
13.                         (entmod (subst (cons 11 newPoint) (assoc 11 dxf) dxf))
    
14.                         (command "LINE" "non" pt2 "non" newPoint "")
    
15.                 )
    
16.                 (progn
    
17.                         (setq ang (angle pt1 pt2))
    
18.                         (setq newPoint (polar pt1 ang len))
    
19.                         (entmod (subst (cons 10 newPoint) (assoc 10 dxf) dxf))
    
20.                         (command "LINE" "non" pt1 "non" newPoint "")
    
21.                 )
    
22.         )
    
23. )

(defun c:tt()<br />         (setq en (entsel))<br />         (setq ent (car en)<br />                 pt (cadr en))<br />         (setq dxf (entget ent))<br />         (setq pt1 (cdr (assoc 10 dxf)) pt2 (cdr (assoc 11 dxf)))<br />         (setq len (getreal))<br />         (if (> (distance pt1 pt) (distance pt2 pt))<br />                 (progn <br />                         (setq ang (angle pt2 pt1))<br />                         (setq newPoint (polar pt2 ang len))<br />                         (entmod (subst (cons 11 newPoint) (assoc 11 dxf) dxf))<br />                         (command "LINE" "non" pt2 "non" newPoint "")<br />                 )<br />                 (progn <br />                         (setq ang (angle pt1 pt2))<br />                         (setq newPoint (polar pt1 ang len))<br />                         (entmod (subst (cons 10 newPoint) (assoc 10 dxf) dxf))<br />                         (command "LINE" "non" pt1 "non" newPoint "")<br />                 )<br />         )<br /> )