简化拉伸S命令的想法，请大家伙进来看看！

cj52000 · 发表于 2015-4-14 12:36:42

大家好：

工作中经常会使用拉伸S命令，把多段线或距形拉伸到某个位置，现有个想法就是说能不能以一条构造线或直线为终点，点一下要拉伸的距形的边，再点一下这条构造线或直线，然后就自动拉伸到和构造线和直线重合，怕表达不清楚，附图
谢谢各位！

Gu_xl · 发表于 2015-4-14 13:48:27

加载XLRX_API:

(defun c:tt (/ e1 e2 p1 p2 v a)
(if (and
(setq e1 (xlrx-entsel
"\n选择拉伸多段线的一条边:"
'((0 . "*polyline"))
)
)
(progn
(redraw (car e1) 3)
(setq
e2 (car (xlrx-entsel "\n选择目标直线边:" '((0 . "*line"))))
)
)
)
(progn
(setq p1 (cadr e1)
e1 (car e1)
p1 (XLRX-Curve-getClosestPointTo e1 p1)
p2 (XLRX-Curve-getClosestPointTo e2 p1)
v (mapcar '- p2 p1)
a (fix (XLRX-Curve-getParamAtPoint e1 p1))
)
(XLRX-moveStretchPoint e1 v a (1+ a))
)
)
(princ)
)

cj52000 · 发表于 2015-4-14 17:51:15

Gu_xl 发表于 2015-4-14 13:48
加载XLRX_API:

谢谢GU-XL版主的热心，程序很好用，满足我的需求，能否，提一点小小的修改，如果要是能框选目标线那就完美了

Gu_xl · 发表于 2015-4-14 20:51:26

本帖最后由 Gu_xl 于 2015-4-14 20:58 编辑

cj52000 发表于 2015-4-14 17:51
谢谢GU-XL版主的热心，程序很好用，满足我的需求，能否，提一点小小的修改，如果要是能框选目标线那就完美 ...

;;自定义Stretch命令 By Gu_xl 2015.04.13
(defun c:stt (/ PTINBOX DRAWBOX P1 P2 SS N
E SSSET PL BOX ENL I PTS L BASEPT
BASE LOOP GR TOPT VEC IDX Line
)
(defun ptinbox (pt box)
(vl-some '(lambda (x)
(and (>= (car pt) (caar x))
(<= (car pt) (caadr x))
(>= (cadr pt) (cadar x))
(<= (cadr pt) (cadadr x))
)
)
box
)
)
(defun drawbox (box / p1 p2 p3 p4)
(setq p1 (car box)
p3 (cadr box)
p2 (list (car p1) (cadr p3))
p4 (list (car p3) (cadr p1))
)
(grdraw p1 p2 1 1)
(grdraw p2 p3 1 1)
(grdraw p3 p4 1 1)
(grdraw p4 p1 1 1)
)
(while (and (setq p1 (getpoint "\n第一点:"))
(setq p2 (getcorner p1 "\n对角点:"))
)
(setq ss (ssget "_C" p1 p2 '((0 . "*polyline"))))
(if ss
(progn (repeat (setq n (sslength ss))
(redraw (setq e (ssname ss (setq n (1- n)))) 3)
(if ssset
(ssadd e ssset)
(setq ssset (ssadd e))
)
)
(setq pl (list (apply 'mapcar (list 'min p1 p2))
(apply 'mapcar (list 'max p1 p2))
)
)
(setq box (cons pl box))
(drawbox pl)
)
)
)
(if ssset
(progn
(if (setq line
(car (xlrx-entsel "\选择直线:" '((0 . "line,*polyline")))
)
)
(progn
(setq enl (XLRX-PickSet->List ssset)
enl (mapcar
'(lambda (x / i pts l)
(setq i -1)
(setq pts (xlrx-get x "StretchPoints"))
(foreach pt pts
(setq i (1+ i))
(if (ptinbox (trans pt 0 1) box)
(setq l (cons i l))
)
)
(cons x (reverse l))
)
enl
)
)
(foreach en enl
(setq e (car en)
idx (cdr en)
pts (xlrx-get e "StretchPoints")
idx (vl-sort
idx
'(lambda (a b / p1 p2)
(<
(distance (setq p1 (nth a pts))
(XLRX-Curve-getClosestPointTo line p1)
)
(distance (setq p2 (nth b pts))
(XLRX-Curve-getClosestPointTo line p2)
)
)
)
)
pt (nth (car idx) pts)
pt1 (XLRX-Curve-getClosestPointTo line pt)
vec (mapcar '- pt1 pt)
)
(apply 'XLRX-moveStretchPoint
(cons e (cons vec idx))
)
)
)
)
)
)
(redraw)
(princ)
)

;;自定义Stretch命令 By Gu_xl 2015.04.13 
(defun c:stt (/            PTINBOX        DRAWBOX            P1          P2        SS    N 
              E            SSSET PL        BOX   ENL   I          PTS        L     BASEPT 
              BASE  LOOP  GR        TOPT  VEC   IDX          Line 
             ) 
  (defun ptinbox (pt box) 
    (vl-some '(lambda (x) 
                (and (>= (car pt) (caar x)) 
                     (<= (car pt) (caadr x)) 
                     (>= (cadr pt) (cadar x)) 
                     (<= (cadr pt) (cadadr x)) 
                ) 
              ) 
             box 
    ) 
  ) 
  (defun drawbox (box / p1 p2 p3 p4) 
 
    (setq p1 (car box) 
          p3 (cadr box) 
          p2 (list (car p1) (cadr p3)) 
          p4 (list (car p3) (cadr p1)) 
    ) 
    (grdraw p1 p2 1 1) 
    (grdraw p2 p3 1 1) 
    (grdraw p3 p4 1 1) 
    (grdraw p4 p1 1 1) 
  ) 
  (while (and (setq p1 (getpoint "\n第一点:")) 
              (setq p2 (getcorner p1 "\n对角点:")) 
         ) 
    (setq ss (ssget "_C" p1 p2 '((0 . "*polyline")))) 
    (if        ss 
      (progn (repeat (setq n (sslength ss)) 
               (redraw (setq e (ssname ss (setq n (1- n)))) 3) 
               (if ssset 
                 (ssadd e ssset) 
                 (setq ssset (ssadd e)) 
               ) 
             ) 
             (setq pl (list (apply 'mapcar (list 'min p1 p2)) 
                            (apply 'mapcar (list 'max p1 p2)) 
                      ) 
             ) 
             (setq box (cons pl box)) 
             (drawbox pl) 
      ) 
    ) 
  ) 
  (if ssset 
    (progn 
      (if (setq        line 
                 (car (xlrx-entsel "\选择直线:" '((0 . "line,*polyline"))) 
                 ) 
          ) 
        (progn 
          (setq        enl (XLRX-PickSet->List ssset) 
                enl (mapcar 
                      '(lambda (x / i pts l) 
                         (setq i -1) 
                         (setq pts (xlrx-get x "StretchPoints")) 
                         (foreach pt pts 
                           (setq i (1+ i)) 
                           (if (ptinbox (trans pt 0 1) box) 
                             (setq l (cons i l)) 
                           ) 
                         ) 
                         (cons x (reverse l)) 
                       ) 
                      enl 
                    ) 
          ) 
          (foreach en enl 
            (setq e   (car en) 
                  idx (cdr en) 
                  pts (xlrx-get e "StretchPoints") 
                  idx (vl-sort 
                        idx 
                        '(lambda (a b / p1 p2) 
                           (< 
                             (distance (setq p1 (nth a pts)) 
                                       (XLRX-Curve-getClosestPointTo line p1) 
                             ) 
                             (distance (setq p2 (nth b pts)) 
                                       (XLRX-Curve-getClosestPointTo line p2) 
                             ) 
                           ) 
                         ) 
                      ) 
                  pt  (nth (car idx) pts) 
                  pt1 (XLRX-Curve-getClosestPointTo line pt) 
                  vec (mapcar '- pt1 pt) 
            ) 
            (apply 'XLRX-moveStretchPoint 
                   (cons e (cons vec idx)) 
            ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (redraw) 
  (princ) 
)

cj52000 · 发表于 2015-4-15 10:28:55

Gu_xl 发表于 2015-4-14 20:51

谢谢Gu_xl 版的热心！

冰之绝恋 · 发表于 2015-4-15 21:59:36

G版很厉害！

bai2000 · 发表于 2015-4-16 11:43:19

能不能改下：对于多个直线有效？即框选内部直线的按指定点移动，不在框内的直线延伸？

wayne_myles · 发表于 2015-7-22 14:32:26

Gu_xl 发表于 2015-4-14 20:51

向G版学习了

wuzheng80425 · 发表于 2015-7-23 20:17:05

向G版学习了

wuzheng80425 · 发表于 2015-7-23 20:17:41

向版主学习了

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

[讨论] 简化拉伸S命令的想法，请大家伙进来看看！

本帖子中包含更多资源

点评