求这样的length程序？

Smile cop

可以把选择的直线或多段线按照两端平均伸缩的方法到用户指定的最终线段长度（有点类似于length-t命令，但是指定总长后它只是在某一端变化！）

炫翔

根据线的角度 修改起点与终点

st788796

http://bbs.xdcad.net/forum.php?mod=redirect&goto=findpost&ptid=667437&pid=3444804

zxq0220

;写了个直线的

2. (defun c:tt ()
   
3. (if (and (setq s1 (entsel "\n选择直线: "))
   
4.           (setq ent (entget(car s1)))
   
5.           (= (cdr(assoc 0 ent)) "LINE")) (progn
   
6.   (setq p1 (cdr(assoc 10 ent)) p2 (cdr(assoc 11 ent))
   
7.         ang (angle p1 p2)
   
8.         l (distance p1 p2))
   
9.   (if (setq newl (getdist (strcat "\n新长度<" (rtos l 2 3) ">: "))) (progn
   
10.    (setq dl (/ (- newl l) 2))
    
11.    (setq ent (subst (cons 11 (polar p2 ang dl)) (assoc 11 ent) ent))
    
12.    (entmod (subst (cons 10 (polar p1 ang (- dl))) (assoc 10 ent) ent))
    
13.   ))
    
14. ))
    
15. (princ)
    
16. )

(defun c:tt ()<br /> (if (and (setq s1 (entsel "\n选择直线: "))<br />           (setq ent (entget(car s1)))<br />           (= (cdr(assoc 0 ent)) "LINE")) (progn<br />   (setq p1 (cdr(assoc 10 ent)) p2 (cdr(assoc 11 ent))<br />         ang (angle p1 p2)<br />         l (distance p1 p2))<br />   (if (setq newl (getdist (strcat "\n新长度<" (rtos l 2 3) ">: "))) (progn<br />    (setq dl (/ (- newl l) 2))<br />    (setq ent (subst (cons 11 (polar p2 ang dl)) (assoc 11 ent) ent))<br />    (entmod (subst (cons 10 (polar p1 ang (- dl))) (assoc 10 ent) ent))<br />   ))<br /> ))<br /> (princ)<br /> )

Smile cop

zxq0220 发表于 2014-3-8 08:23
;写了个直线的

你写的这个程序运行结果不正确，能帮忙修改下吗？谢谢！

zxq0220

rxing 发表于 2014-3-9 17:37
你写的这个程序运行结果不正确，能帮忙修改下吗？谢谢！

程序改了，再试试。

Free-Lancer

对 line 而言，习惯用 ActiveX

1. (defun c:tt (/ d)
   
2.   (if (setq d (getdist "\nLength: "))
   
3.     (progn
   
4.       (fy:begin)
   
5.       (while (ssget '((0 . "Line")))
   
6.         (mapcar        '(lambda (x /  len vx an)
   
7.                    (setq len (vlax-get x 'Length)
   
8.                          vx  (* 0.5 (- len d))
   
9.                          an  (vlax-get x 'Angle)
   
10.                    )
    
11.                    (vlax-put
    
12.                      x
    
13.                      'Startpoint
    
14.                      (polar (vlax-get x 'Startpoint) an vx)
    
15.                    )
    
16.                    (vlax-put
    
17.                      x
    
18.                      'EndPoint
    
19.                      (polar (vlax-get x 'Endpoint) (+ pi an) vx)
    
20.                    )
    
21.                  )
    
22.                 (fy:cset->objs)
    
23.         )
    
24.       )
    
25.       (fy:end)
    
26.     )
    
27.   )
    
28.   (princ)
    
29. )

(defun c:tt (/ d)<br />   (if (setq d (getdist "\nLength: "))<br />     (progn<br />       (fy:begin)<br />       (while (ssget '((0 . "Line")))<br />         (mapcar        '(lambda (x /  len vx an)<br />                    (setq len (vlax-get x 'Length)<br />                          vx  (* 0.5 (- len d))<br />                          an  (vlax-get x 'Angle)<br />                    )<br />                    (vlax-put<br />                      x<br />                      'Startpoint<br />                      (polar (vlax-get x 'Startpoint) an vx)<br />                    )<br />                    (vlax-put<br />                      x<br />                      'EndPoint<br />                      (polar (vlax-get x 'Endpoint) (+ pi an) vx)<br />                    )<br />                  )<br />                 (fy:cset->objs)<br />         )<br />       )<br />       (fy:end)<br />     )<br />   )<br />   (princ)<br /> )

Smile cop

Free-Lancer 发表于 2014-3-10 08:38
对 line 而言，习惯用 ActiveX

里面的一些函数如(fy:begin) (fy:end)能否把代码也加上，谢谢！

Smile cop

zxq0220 发表于 2014-3-8 08:23
;写了个直线的

程序运行成功，谢谢！但在实际情况中，常常需要一次对多个线段实现缩放，也就是说能不能实现多选线段，然后遍历修改线段，谢谢！

zxq0220

rxing 发表于 2014-3-10 12:41
程序运行成功，谢谢！但在实际情况中，常常需要一次对多个线段实现缩放，也就是说能不能实现多选线段，然 ...

多选加循环就行了。