沿上次继续改进，线段和圆弧批量伸长或缩短

缘份呐

线段和圆弧的批量伸长或缩短
正数为伸长，负数为缩短
望各位老师指点，改进。

vlisp2012

程序呢？

缘份呐

vlisp2012 发表于 2012-6-15 19:41
程序呢？

哦，忘记了，不好意思。马上贴上。
请指点下，希望改进更好。

缘份呐

(defun c:lll()
(princ "批量伸长或缩短")
(setq os (getvar "osmode"))
(setvar "osmode" 0)
(setq d (getreal "\n请输入每边变化值: "))
(princ "\n请选择对象：")
(setq ss(ssget '((0 . "line,arc"))))
(setq len(sslength ss))
(setq i 0)
(if (/= NIL ss)
  (repeat len
(setq en1(ssname ss i))
(setq e1 (entget en1))
(setq TS (cdr(assoc 0 e1)))
(cond
  ((= TS "LINE")
(setq pt1 (cdr (assoc 10 e1)))
(setq ptt1 (cdr (assoc 11 e1)))
(setq px1 (car pt1)
       py1 (cadr pt1)
       z0 (list px1 py1))
(setq pxx1 (car ptt1)
       pyy1 (cadr ptt1)
       z2 (list pxx1 pyy1))
(setq zx1 (/ (+ px1 pxx1) 2.0)
       zy1 (/ (+ py1 pyy1) 2.0)
       z1 (list zx1 zy1))
(setq LD (distance pt1 ptt1))
(if (> (- d) (/ LD 2.0)) (exit))
(setq jd (angle z0 z2))
(setq b0 (polar z0 (+ pi jd) d))
(setq bn (polar z2 jd d ))
(setq e1 (subst (cons 10 b0) (assoc 10 e1) e1))
(setq e1 (subst (cons 11 bn) (assoc 11 e1) e1))
(entmod e1)
)
((= TS "ARC")
(setq o (cdr (assoc 10 e1))
       r (cdr (assoc 40 e1))
       p0 (cdr (assoc 50 e1))
       pn (cdr (assoc 51 e1))
       hd0 (- pn p0)
       zdhd (+ p0 (/ hd0 2.0)))
(if (>= d (* (/ (abs (/ hd0 2.0)) pi) pi r)) (exit))
(setq ds (atof (angtos hd0 0 4))
       zc (* 2 pi r (/ ds 360)))
(setq xds (/ (* d 360) (* 2 pi r)))
(setq xhd (* pi (/ xds 180)))
(if (>= (- d) (/ zc 2.0))  (exit))
(setq e1 (subst (cons 50 (- p0 xhd)) (assoc 50 e1) e1))
(setq e1 (subst (cons 51 (+ pn xhd)) (assoc 51 e1) e1))
(entmod e1)
)
)
(setq i (+ i 1))
)
)
(setvar "osmode" os)
(princ)
)

yjr111

2. ;;;;程序未处理缩短长度大于已有长度或圆弧增大长度超过圆周长的情况，请自行添加判断;;;;;;;;;;
   
3. (defun c:doublextend (/  ss e n )
   
4. (setq oldosmode (getvar "osmode"))
   
5. (setvar "osmode" 0)
   
6. (setvar "cmdecho" 0)
   
7. (if *dist*
   
8.   (setq dist (getdist (strcat "\n请输入每边变化值:< " (rtos *dist* 2 0) ">")))
   
9.   (setq dist (getdist "\n请输入每边变化值: "))
   
10. )
    
11. (if (not dist)  (setq dist *dist*)  (setq *dist* dist))
    
12. (princ "\n请选择对象：")
    
13. (while(setq ss  (ssget '((0 . "LINE,ARC"))))
    
14. (while  (and ss (>(setq n(sslength ss))0))
    
15. 。。。。。。。。。。。。。。。。。。

;;;;程序未处理缩短长度大于已有长度或圆弧增大长度超过圆周长的情况，请自行添加判断;;;;;;;;;;<br /> (defun c:doublextend (/  ss e n )<br /> (setq oldosmode (getvar "osmode"))<br /> (setvar "osmode" 0)<br /> (setvar "cmdecho" 0)<br /> (if *dist*<br />   (setq dist (getdist (strcat "\n请输入每边变化值:< " (rtos *dist* 2 0) ">")))<br />   (setq dist (getdist "\n请输入每边变化值: "))<br /> )<br /> (if (not dist)  (setq dist *dist*)  (setq *dist* dist))<br /> (princ "\n请选择对象：")<br /> (while(setq ss  (ssget '((0 . "LINE,ARC"))))<br /> (while  (and ss (>(setq n(sslength ss))0))<br /> 。。。。。。。。。。。。。。。。。。

flytoday

对有扩展属性的线及PL线无效请严哥升级下。。完美程序哈

lzg8877

学习..........................

flytoday

严哥改了变成这样了啊。。用不了~
命令:
DOUBLEXTEND
请输入每边变化值:< 100>
请选择对象：
选择对象: 找到 1 个
选择对象:
未知命令“DOUBLEXTEND”。按 F1 查看帮助。

flytoday

严哥5楼附件只能适用单边啊~~~~~~[em0]

longer1000