自定义Stretch命令

牢固 · 发表于 2014-12-16 17:01:08

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由牢固于 2014-12-17 09:46 编辑

版块根据arx帖子模拟实现STRETCH命令的ARX实现代码用API写了个Lisp版本:

;;自定义Stretch命令 By Gu_xl
(defun c:stt (/ PTINBOX DRAWBOX P1 P2 SS N
E SSSET PL BOX ENL I PTS L
BASEPT BASE LOOP GR TOPT VEC IDX
)
(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 . "*line"))))
(setq ss (ssget "_C" p1 p2)) ;;可按需求修改过滤表
(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
(setq enl (xdrx_Pickset->ents ssset))
(setq enl
(mapcar
'(lambda (x / i pts l)
(setq i -1)
(setq pts (xdrx_getpropertyvalue x "StretchPoint"))
(foreach pt pts
(setq i (1+ i))
(if (ptinbox (trans pt 0 1) box)
(setq l (cons i l))
)
)
(cons x (reverse l))
)
enl
)
)
(while (not (setq basept (getpoint "\n基点:"))))
(setq base basept)
(setq loop t)
(while loop
(setq gr (grread t 15))
(cond ((= 5 (car gr))
(setq toPt (cadr gr))
(redraw) (mapcar '(lambda (x) (drawbox x)) box)
(grdraw base toPt 3 1)
(setq vec (mapcar '- topt basept))
(foreach en enl
(setq e (car en)
idx (cdr en)
)
(apply 'xdrx_entity_MoveStretchPoint
(cons e (cons vec idx))
)
)
(setq basept toPt)
)
((= 3 (car gr)) (setq loop nil))
)
)
)
)
(redraw)
(princ)
)

;;自定义Stretch命令 By Gu_xl 
(defun c:stt (/  PTINBOX        DRAWBOX      P1     P2    SS   N 
    E      SSSET  PL     BOX    ENL     I    PTS   L 
    BASEPT BASE   LOOP   GR      TOPT   VEC    IDX 
         ) 
  (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 . "*line")))) 
    (setq ss (ssget "_C" p1 p2)) ;;可按需求修改过滤表 
    (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 
      (setq enl (xdrx_Pickset->ents ssset)) 
      (setq enl 
       (mapcar 
         '(lambda  (x / i pts l) 
      (setq i -1) 
      (setq pts (xdrx_getpropertyvalue x "StretchPoint")) 
      (foreach pt pts 
        (setq i (1+ i)) 
        (if  (ptinbox (trans pt 0 1) box) 
          (setq l (cons i l)) 
        ) 
      ) 
      (cons x (reverse l)) 
    ) 
         enl 
       ) 
      ) 
      (while (not (setq basept (getpoint "\n基点:")))) 
      (setq base basept) 
      (setq loop t) 
      (while loop 
  (setq gr (grread t 15)) 
  (cond ((= 5 (car gr)) 
         (setq toPt (cadr gr)) 
         (redraw)        (mapcar '(lambda (x) (drawbox x)) box) 
         (grdraw base toPt 3 1) 
         (setq vec (mapcar '- topt basept)) 
         (foreach  en enl 
     (setq e   (car en) 
           idx (cdr en) 
     ) 
     (apply  'xdrx_entity_MoveStretchPoint 
      (cons e (cons vec idx)) 
     ) 
         ) 
         (setq basept toPt) 
        ) 
        ((= 3 (car gr)) (setq loop nil)) 
  ) 
      ) 
    ) 
  ) 
  (redraw) 
  (princ) 
)

st788796 · 发表于 2014-12-16 17:40:07

ET 中有个 Mstretch 也是这个功能

/db_自贡黄明儒_ · 发表于 2014-12-17 08:26:05

本帖最后由 /db_自贡黄明儒_ 于 2014-12-19 14:46 编辑

st788796 发表于 2014-12-16 17:40
ET 中有个 Mstretch 也是这个功能

grdraw画的，滚动鼠标会消失，Mstretch的虚框不会，用lisp用什么办法做得象Mstretch一样？

G版，我说的是如下函数
(defun C:w1 (/ P PTS X Y)
(while (setq p (getpoint))
(setq pts (cons p pts))
(mapcar '(lambda (x y) (GRDRAW x y 1)) pts (cdr pts))
)
)
在执行过程中滚动鼠标，虚框仍要消失，怎么办？

st788796 · 发表于 2014-12-17 08:33:21

/db_自贡黄明儒_ 发表于 2014-12-17 08:26
grdraw画的，滚动鼠标会消失，Mstretch的虚框不会，用lisp用什么办法做得象Mstretch一样？

用xdrx_pointmonitor不停的redraw grdraw

牢固 · 发表于 2014-12-17 09:41:54

/db_自贡黄明儒_ 发表于 2014-12-17 08:26
grdraw画的，滚动鼠标会消失，Mstretch的虚框不会，用lisp用什么办法做得象Mstretch一样？

要保留虚框,在Loop循环里加一句画框的代码:(mapcar '(lambda (x) (drawbox x)) box)即可!

st788796 · 发表于 2014-12-17 11:24:34

Jig也是要更新显示

/db_自贡黄明儒_ · 发表于 2014-12-17 16:16:30

牢固发表于 2014-12-17 09:41
要保留虚框,在Loop循环里加一句画框的代码mapcar '(lambda (x) (drawbox x)) box)即可!

应该不是标准答案，loop中总要做事。除非不擦出原来的，但问题是就有许多重叠在一起了。

牢固 · 发表于 2014-12-17 16:51:14

/db_自贡黄明儒_ 发表于 2014-12-17 16:16
应该不是标准答案，loop中总要做事。除非不擦出原来的，但问题是就有许多重叠在一起了。

不明白你什么意思?什么就重叠在一起了?你来搞个标准答案吧!
实际效果演示:

/db_自贡黄明儒_ · 发表于 2014-12-18 08:30:30

牢固发表于 2014-12-17 16:51
不明白你什么意思?什么就重叠在一起了?你来搞个标准答案吧!
实际效果演示:

G版，你的这个行。我是说用lisp.

牢固 · 发表于 2014-12-18 11:32:16

/db_自贡黄明儒_ 发表于 2014-12-18 08:30
G版，你的这个行。我是说用lisp.

难道我用的不是Lisp?{:soso_e114:}

守仁格竹GM · 发表于 2014-12-18 11:37:55

/db_自贡黄明儒_ 发表于 2014-12-18 08:30
G版，你的这个行。我是说用lisp.

黄总可以模拟对应XDAPI的函数也挺有意思{:soso_e113:}

Lispboy · 发表于 2014-12-18 11:54:57

守仁格竹GM 发表于 2014-12-18 11:37
黄总可以模拟对应XDAPI的函数也挺有意思

是啊，如果老黄能把API再“翻译”成纯LISP，那功力肯定要提高几个数量级了。

st788796 · 发表于 2014-12-18 11:57:54

绝对众神之神了！

20055647 · 发表于 2015-1-9 20:43:46

代码注释不够多，不是很懂

pp521yy · 发表于 2015-1-9 22:36:24

都是牛人啊

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

[教学] 自定义Stretch命令

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

点评

点评

点评

点评

点评

点评

点评