增强一点拉伸功能

yjr111 · 发表于 2012-3-30 23:46

本帖最后由 yjr111 于 2012-3-30 23:51 编辑

有时候拉伸物体不好选择，最好选择一条边即可拉伸，实际遇到也很多
hgf876的帖子http://bbs.mjtd.com/thread-92145-1-1.html 拉伸功能非常强大，也非常好用，可惜不能动态，晚上兴起，利用stretch命令自己写了一个，好像也能用，特发一贴，有兴趣的哥哥姐姐弟弟妹妹可以下载玩玩。。。

(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)))
)

(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))) 
  )

GNJLISP · 发表于 2018-1-6 12:00

有倒角和圆角的就不行，可以改一下吗？

GNJLISP · 发表于 2018-1-5 17:35

本帖最后由 GNJLISP 于 2018-1-6 12:01 编辑

有倒角和圆角的就不行，可以改一下吗？

cxs259 · 发表于 2012-3-31 02:52

楼主的程序可以输入距离，大家可以试用了！挺不错的

dhy · 发表于 2012-3-31 08:20

我在05CAD操作，显示:
“选择要拉伸的矩形边
必须选择一个交叉窗口或交叉多边形来拉伸。”
是什么原因呢

xiaxiang · 发表于 2012-3-31 08:27

可以动态显示两条相邻边的长度吗，谢谢

yzxgwl · 发表于 2012-3-31 09:04

876的是arx的有版本限制！

自贡黄明儒 · 发表于 2012-3-31 12:35

G版都出手了，想必是好程序，

669423907 · 发表于 2012-3-31 12:48

yjr111 大师的高作，很好用！

xyh · 发表于 2012-3-31 16:06

两者效果不同，hgf876 的拉伸有点类似scale命令局部比例放大的效果，
这个是stretch的拉伸功能。
选择好后按空格，出现拉伸到外面的情况。

xyh · 发表于 2012-3-31 16:09

选择好后按空格，出现拉伸到外面的情况。用的是line线，在cad2011中。

ps122hb · 发表于 2012-3-31 16:11

下载试用一下，谢谢分享

账号		自动登录	找回密码
密码			注册

增强一点拉伸功能

评分

本帖子中包含更多资源

本帖子中包含更多资源

点评

点评