怎样实现多义线的随意拉伸
本帖最后由 menger_8 于 2011-11-7 20:48 编辑[之前下的一个可以随意拉伸的vlx，点选多边形的任意边然后移动鼠标就可以实现与stretch相同的效果，想了很久，矩形很容易实现，但不规则形状的多边形不知道如何判断选中的是哪个边并实现拉伸，找了很久好像没有这方面的函数，望各位大虾能提供思路，附上网上下载的别人的插件
attach]62228
这个功能好，期待ing 在autocad的教学里就有，每个人都可以自学。 多谢楼主分享 这个问题没有高手能解决么，期待中…… 本帖最后由 xiaxiang 于 2011-11-9 14:26 编辑
(defun c:tt(/ pta3 ptb3 pt2n pt2nb i0)
(setq oldos (getvar "osmode")) ;保存捕捉特性给oldos
(setvar "cmdecho" 0)
(setvar "osmode" 247)
(command "undo" "be")
(if(= dis nil)
(while(not(setq dis (getreal "\n请输入拉伸距离:"))))
(setq dis (getreal (strcat "\n请输入拉伸距离:<" (rtos dis 2) ">")))
)
(if(= dis nil)(setq dis disold)(setq disold dis))
(while(setq s1 (entsel "\n请指定拉伸的边:"))
(setq pta3 nil ptb3 nil pt2n nil pt2nb nil i0 nil)
(setq enlst (entget(car s1)))
(setq pt_lst'())
(if(= (cdr(assoc 0 enlst)) "LWPOLYLINE")
(progn
(setq p1 (cadr s1))
(command "circle" p1 1)
(setq p1 (cdr(assoc 10 (entget(entlast)))))
(entdel (entlast))
(setvar "osmode" 0)
(terpri)(while(not(setq ps1 (getpoint "\n请指定拉伸方向:"))))
(setvar "osmode" 247)
(foreach i enlst (if(or(= (car i) 10)(= (car i) 42))(setq pt_lst (cons (cdr i) pt_lst))))
(setq pt_lst (reverse pt_lst))
(setq i 0)
(while (setq p0 (nth i pt_lst))
(setq p2 (nth (+ i 2) pt_lst))
(if(= p2 nil)(setq p2 (nth 0 pt_lst) i0 -2)(setq i0 i))
(setq ang1a (angle p0 p1))
(setq ang2a (angle p1 p2))
(if(or(equal ang1a ang2a 0.001)(equal (+ pi pi ang1a) ang2a 0.001)(equal (+ pi pi ang2a) ang1a 0.001))
(progn
(setq pta1 p0 ptb1 p2)
(command "area" "o" (car s1))
(setq are1 (getvar "Perimeter"))
(command "offset" "t" s1 ps1 "")
(setq ssx1 (entlast))
(command "area" "o" ssx1)
(setq are2 (getvar "Perimeter"))
(entdel ssx1)
(if(> are2 are1)(setq ffxx "1")(setq ffxx "0"))
(if(<(- i 1)0)(setq tdza (nth (+(- i 1)(length pt_lst))pt_lst))
(setq tdza (nth (- i 1) pt_lst)))
(if(<(- i 2)0)(setq pta2 (nth (+(- i 2)(length pt_lst))pt_lst))
(setq pta2 (nth (- i 2) pt_lst)))
(if(or(/= tdza 0)(and(= tdza 0)(<= (distance pta2 pta1) (* 2 (sqrt 2)))))
(progn
(if(<(- i 3)0)(setq tdza1 (nth (+(- i 3)(length pt_lst))pt_lst))
(setq tdza1 (nth (- i 3) pt_lst)))
(if(= tdza1 0)
(progn
(if(<(- i 4)0)(setq pta3 (nth (+(- i 4)(length pt_lst))pt_lst))
(setq pta3 (nth (- i 4) pt_lst)))
(setq angla (angle pta3 pta2))
)
)
)
(setq angla (angle pta2 pta1))
)
(if(<(+ i0 3)(length pt_lst))
(setq tdzb (nth (+ i0 3) pt_lst))
(setq tdzb (nth (-(+ i0 3)(length pt_lst)) pt_lst))
)
(if(<(+ i0 4)(length pt_lst))
(setq ptb2 (nth (+ i0 4) pt_lst))
(setq ptb2 (nth (-(+ i0 4)(length pt_lst)) pt_lst))
)
(if(or(/= tdzb 0)(and(= tdzb 0)(<= (distance ptb2 ptb1) (* 2 (sqrt 2)))))
(progn
(if(<(+ i0 5)(length pt_lst))
(setq tdzb1 (nth (+ i0 5) pt_lst))
(setq tdzb1 (nth (-(+ i0 5)(length pt_lst)) pt_lst))
)
(if(= tdzb1 0)
(progn
(if(<(+ i0 6)(length pt_lst))
(setq ptb3 (nth (+ i0 6) pt_lst))
(setq ptb3 (nth (-(+ i0 6)(length pt_lst)) pt_lst))
)
(setq anglb (angle ptb3 ptb2))
)
)
)
(setq anglb (angle ptb2 ptb1))
)
(setq anga1 (angle pta1 ptb1))
(setq angb1 (angle ptb1 pta1))
(if(equal anga1 (* 2 pi) 0.0001)(setq anga1 0))
(if(equal angb1 (* 2 pi) 0.0001)(setq angb1 0))
(setq anga2 (+ pi angla) angb2 (+ pi anglb))
(if(>= anga2(* 2 pi))(setq anga2(- anga2 pi pi)))
(if(>= angb2(* 2 pi))(setq angb2(- angb2 pi pi)))
(if(> anga2 anga1)(setq anga3(- anga2 anga1))(setq anga3(- anga1 anga2)))
(if(> angb2 angb1)(setq angb3(- angb2 angb1))(setq angb3(- angb1 angb2)))
(setq disna (/ dis (abs(sin anga3))))
(setq disnb (/ dis (abs(sin angb3))))
(if(= ffxx "1")(setq pt1n (polar pta1 angla disna))(setq pt1n (polar pta1 (+ pi angla) disna)))
(if(= ffxx "1")(setq pt1nb(polar ptb1 anglb disnb))(setq pt1nb(polar ptb1 (+ pi anglb) disnb)))
(if(/= pta3 nil)(if(= ffxx "1")(setq pt2n (polar pta2 angla disna))(setq pt2n (polar pta2 (+ pi angla) disna))))
(if(/= ptb3 nil)(if(= ffxx "1")(setq pt2nb(polar ptb2 anglb disnb))(setq pt2nb(polar ptb2 (+ pi anglb) disnb))))
(setq i (length pt_lst))
)
)
(setq i (+ 2 i))
)
(setq e (car s1))
(setq m (entget e))
(setq m (subst (cons 10 pt1n)(cons 10 pta1)m))
(entmod m)
(setq m (subst (cons 10 pt1nb)(cons 10 ptb1)m))
(entmod m)
(entupd e)
(if(/= pt2n nil)
(progn
(setq m (subst (cons 10 pt2n)(cons 10 pta2)m))
(entmod m)
(entupd e)
)
)
(if(/= pt2nb nil)
(progn
(setq m (subst (cons 10 pt2nb)(cons 10 ptb2)m))
(entmod m)
(entupd e)
)
)
)
(prompt "\n<您选择的线不是多义线,请串接成多义线再运行此程序!!!>")
)
)
(command "undo" "e")
(setvar "osmode" oldos) ;还原捕捉
)
本帖最后由 xshrimp 于 2011-11-9 15:52 编辑
参考
(defun c:ofss (/ E G O P1 P2 V1 V2 V3)
;|
*************************************************************************************************
*
* by ElpanovEvgeniy 26.02.2010
*
* ----------------
* 27.02.2010 8:30
* fix bug for acad 2004 (vlax-curve-getFirstDeriv e (vlax-curve-getEndParam e))
* ----------------
* 27.02.2010 8:55
* fix bug for first arc segment
*************************************************************************************************
|;
(setq e(entsel)
p1 (cadr e)
e(car e)
p1 (fix (vlax-curve-getParamAtPoint e (vlax-curve-getClosestPointTo e p1)))
o(vlax-ename->vla-object e)
) ;_setq
(if (= 1 (cdr (assoc 70 (entget e))))
(cond ((zerop p1)
(setq p2 (1+ p1)
v1 (list (vlax-curve-getPointAtParam e (vlax-curve-getEndParam e))
(vlax-curve-getFirstDeriv e (1- (vlax-curve-getEndParam e)))
) ;_list
v2 (list (vlax-curve-getPointAtParam e p1) (vlax-curve-getFirstDeriv e 0.5))
v3 (list (vlax-curve-getPointAtParam e p2) (vlax-curve-getFirstDeriv e 1.5))
) ;_setq
)
((= p1 (1- (vlax-curve-getEndParam e)))
(setq p2 0
v1 (list (vlax-curve-getPointAtParam e (1- p1))
(vlax-curve-getFirstDeriv e (+ (1- p1) 0.5))
) ;_list
v2 (list (vlax-curve-getPointAtParam e p1) (vlax-curve-getFirstDeriv e (+ p1 0.5)))
v3 (list (vlax-curve-getPointAtParam e p2) (vlax-curve-getFirstDeriv e (+ p2 0.5)))
) ;_setq
)
((setq p2 (1+ p1)
v1 (list (vlax-curve-getPointAtParam e (1- p1))
(vlax-curve-getFirstDeriv e (+ (1- p1) 0.5))
) ;_list
v2 (list (vlax-curve-getPointAtParam e p1) (vlax-curve-getFirstDeriv e (+ p1 0.5)))
v3 (list (vlax-curve-getPointAtParam e p2) (vlax-curve-getFirstDeriv e (+ p2 0.5)))
) ;_setq
)
) ;_cond
(cond ((zerop p1)
(setq p2 (1+ p1)
v2 (list (vlax-curve-getPointAtParam e 0) (vlax-curve-getFirstDeriv e 0.5))
v1 (list (car v2) (list (cadadr v2) (- (caadr v2)) 0.))
v3 (list (vlax-curve-getPointAtParam e p2) (vlax-curve-getFirstDeriv e 1.5))
) ;_setq
)
((= p1 (1- (vlax-curve-getEndParam e)))
(setq p2 (vlax-curve-getEndParam e)
v1 (list (vlax-curve-getPointAtParam e (1- p1))
(vlax-curve-getFirstDeriv e (+ (1- p1) 0.5))
) ;_list
v2 (list (vlax-curve-getPointAtParam e p1) (vlax-curve-getFirstDeriv e (+ p1 0.5)))
v3 (list (vlax-curve-getPointAtParam e p2) (list (cadadr v2) (- (caadr v2)) 0.))
) ;_setq
)
((setq p2 (1+ p1)
v1 (list (vlax-curve-getPointAtParam e (1- p1))
(vlax-curve-getFirstDeriv e (+ (1- p1) 0.5))
) ;_list
v3 (list (vlax-curve-getPointAtParam e p2) (vlax-curve-getFirstDeriv e (+ p2 0.5)))
v2 (list (vlax-curve-getPointAtParam e p1) (vlax-curve-getFirstDeriv e (+ p1 0.5)))
) ;_setq
)
) ;_cond
) ;_if
(while (= (car (setq g (grread nil 5 0))) 5)
(vla-put-coordinate
o
p1
(vlax-make-variant
(vlax-safearray-fill (vlax-make-safearray 5 '(0 . 1))
(reverse (cdr (reverse (inters (car v1)
(mapcar '+ (car v1) (cadr v1))
(cadr g)
(mapcar '+ (cadr g) (cadr v2))
nil
) ;_inters
) ;_reverse
) ;_cdr
) ;_reverse
) ;_vlax-safearray-fill
) ;_vlax-make-variant
) ;_vla-put-coordinate
(vla-put-coordinate
o
p2
(vlax-make-variant
(vlax-safearray-fill (vlax-make-safearray 5 '(0 . 1))
(reverse (cdr (reverse (inters (car v3)
(mapcar '+ (car v3) (cadr v3))
(cadr g)
(mapcar '+ (cadr g) (cadr v2))
nil
) ;_inters
) ;_reverse
) ;_cdr
) ;_reverse
) ;_vlax-safearray-fill
) ;_vlax-make-variant
) ;_vla-put-coordinate
) ;_while
(princ)
)
经测试，有时候为何不能延伸？要点两下才又执行 如果能用grread写出每次拉伸的步长，就更棒了！