本帖最后由 xj6019 于 2020-10-22 12:44 编辑
从论坛里面找到的代码，现在有如下的请求，希望有朋友可以帮实现一下：
选边拉伸的代码， 优化成 以所选边线的垂直方向进行拉伸（为了适应斜边的情况，此情况下输入的数值也是选线垂直方向的数值）,并需要解决所选边线端点不在屏幕内的话端点连接位置不能执行，会断开或者不修剪的问题，有斜边的时候会错误识别被错误拉伸，尤其是三角形，总会有一个边的时候是错误的。现在上传附件不能用的可能性大，测试的时候可以画个三角形，每个边往内外先手动偏移个距离，然后偏移出来的线端点和三角形顶点相连，然后用代码选刚才偏移出来的线，进行偏移测试，三个边都试一下哦，因为现在的代码，其中一条边会出问题，拉伸的时候。 这个代码输入的拉伸数值是否可以记忆，需保留动态预览的效果。 整体代码中有其他可以优化的地方，也劳烦考虑的更合理一点，使代码整体变的更严谨一点，拜托了！
原帖地址如下
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=92753&extra=&highlight=%D4%F6%C7%BF%D2%BB%B5%E3%C0%AD%C9%EC%B9%A6%C4%DC&page=1
本帖最后由 yjr111 于 2012-3-30 23:51 编辑
有时候拉伸物体不好选择，最好选择一条边即可拉伸，实际遇到也很多
hgf876的帖子http://bbs.mjtd.com/thread-92145-1-1.html 拉伸功能非常强大，也非常好用，可惜不能动态，晚上兴起，利用stretch命令自己写了一个，好像也能用，特发一贴，有兴趣的哥哥姐姐弟弟妹妹可以下载玩玩。。。
[code="lisp] (defun c:qstretch(/ e pt vla_e p1 plst n anglst stretchplst )
;;;;;;;;;;;;;;;;选边;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq e(car(setq ent(entsel"\n选择要拉伸的矩形边")))
pt(cadr ent)
vla_e(vlax-ename->vla-object e)
p1(vlax-curve-getclosestpointto e pt)
)
;;;;;;;对多段线或直线有效;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(cond((= (vla-get-objectname vla_e) "AcDbPolyline")
(setq plst (lst->3p
(vlax-safearray->list(vlax-variant-value(vla-get-coordinates vla_e)))
2
)
)
)
((= (vla-get-objectname vla_e) "AcDb2dPolyline")
(setq plst (lst->3p
(vlax-safearray->list(vlax-variant-value(vla-get-coordinates vla_e)))
3
)
)
)
((= (vla-get-objectname vla_e) "AcDbLine")
(setq plst (list(vlax-curve-getstartpoint e)
(vlax-curve-getendpoint e)
)
)
)
)
;;;;;;;;;;根据角度相等找到选边时点击点的边的2个点，此方法并不严谨，可能会出错;;;;;;;;;;;;;;;;;;;
(mapcar '(lambda(x) (setq anglst (cons(list(if (>= (angle p1 x)pi)(angle x p1)(angle p1 x)) x) anglst)))plst)
(setq anglst (vl-sort anglst '(lambda(x y) (< (car x)(car y) ))))
(while anglst
(setq assocang (caar anglst) assocp (cadar anglst))
(if(member(fixnum(caar anglst))(mapcar '(lambda(x)(fixnum (car x))) (setq anglst (cdr anglst))))
(setq stretchplst(list assocp (cadar anglst)))
)
)
(setq stretchplst
(vl-sort stretchplst(function(lambda(x y)
(if (equal (car x) (car y))(< (cadr x) (cadr y))(< (car x) (car y)))))))
;;;;;;;;;;;;;;;;;;;;;;;;stretch命令;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(vl-cmdf "_.stretch"
(ssget "c" (list (- (car(car stretchplst)) 1e-3)(- (cadr(car stretchplst)) 1e-3))
(list (+(car(cadr stretchplst)) 1e-3)(+ (cadr(cadr stretchplst)) 1e-3)))
"" p1 pause)
(princ)
)
;;;;;;函数：将点表num个一组重新组表，用于处理多段线顶点坐标;;;;;;;;;;;;;;;;;
(defun lst->3p (lst num / n lst_new1 lst_newpoint)
(setq n 0)
(mapcar
(function
(lambda (x)
(setq lst_new1 (append lst_new1 (list x)))
(if (= (rem (1+ n) num) 0)
(progn
(setq lst_newpoint (append (list lst_new1) lst_newpoint))
(setq lst_new1 nil)
)
)
(setq n (1+ n))
)
)
lst
)
lst_newpoint
)
(defun fixnum(bl)
(setq bl (/(fix (* bl (expt 10.0 3)))(expt 10.0 3)))
)[/code] |
| 
发表于 2020-10-22 12:35:38
置顶卡
变色卡
显身卡
楼主