求一个改进的拉伸，移动lisp

wxa123wl · 发表于 2014-3-30 00:14:34

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

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

×

平时工作中经常会改图，，然后就是把好多东西都拉伸固定距离，或者移动固定距离，故每次都得输入一遍距离，，希望有大神弄一个，或者分享一个，，先指定距离和方向然后选择问题，确定后就是移动（拉伸）指定方向固定距离！这样就不用每次都输入距离了，哈哈，，

st788796 · 发表于 2014-3-31 00:22:59

(defun c:xm (/ ss pb dis)
(if
(and (setq ss (ssget))
(progn
(setq pb (car (xdrx_entity_box ss)))
(if
(setq
dis (getdist pb
(if **GlobleDist**
(strcat "\nDistance<"
(vl-princ-to-string **GlobleDist**)
">: "
)
"\nDistance: "
)
)
)
(setq **GlobleDist** dis)
(setq dis **GlobleDist**)
)
)
)
(vl-cmdf ".move"
ss
""
pb
(polar pb (angle pb (cadr (grread T 15))) dis)
)
)
(princ)
)
(defun c:xs (/ ss pb dis)
(if
(and (setq ss (ssget))
(progn
(setq pb (car (xdrx_entity_box ss)))
(if
(setq
dis (getdist pb
(if **GlobleDist**
(strcat "\nDistance<"
(vl-princ-to-string **GlobleDist**)
">: "
)
"\nDistance: "
)
)
)
(setq **GlobleDist** dis)
(setq dis **GlobleDist**)
)
)
)
(vl-cmdf ".stretch"
ss
""
pb
(polar pb (angle pb (cadr (grread T 15))) dis)
)
)
(princ)
)

(defun c:xm (/ ss pb dis) 
  (if 
    (and (setq ss (ssget)) 
         (progn 
           (setq pb (car (xdrx_entity_box ss))) 
           (if 
             (setq 
               dis (getdist pb 
                            (if        **GlobleDist** 
                              (strcat "\nDistance<" 
                                      (vl-princ-to-string **GlobleDist**) 
                                      ">: " 
                              ) 
                              "\nDistance: " 
                            ) 
                   ) 
             ) 
              (setq **GlobleDist** dis) 
              (setq dis **GlobleDist**) 
           ) 
         ) 
    ) 
     (vl-cmdf ".move" 
              ss 
              "" 
              pb 
              (polar pb (angle pb (cadr (grread T 15))) dis) 
     ) 
  ) 
  (princ) 
) 
(defun c:xs (/ ss pb dis) 
  (if 
    (and (setq ss (ssget)) 
         (progn 
           (setq pb (car (xdrx_entity_box ss))) 
           (if 
             (setq 
               dis (getdist pb 
                            (if        **GlobleDist** 
                              (strcat "\nDistance<" 
                                      (vl-princ-to-string **GlobleDist**) 
                                      ">: " 
                              ) 
                              "\nDistance: " 
                            ) 
                   ) 
             ) 
              (setq **GlobleDist** dis) 
              (setq dis **GlobleDist**) 
           ) 
         ) 
    ) 
     (vl-cmdf ".stretch" 
              ss 
              "" 
              pb 
              (polar pb (angle pb (cadr (grread T 15))) dis) 
     ) 
  ) 
  (princ) 
)

wxa123wl · 发表于 2014-3-30 18:14:34

(defun c:Rss (/ s_disyd date ent)
 (princ "\n***>>>>>Welcome to 选字拉伸<<<<***")
 (setvar "ORTHOMODE" 1)
 (while (setq date (entsel "\n请选择数字:"))
 (setq ent (entget (car date)))
 (setq movedis (atof (cdr (assoc 1 ent))))
 (command "._erase" date "")
 (command "._STRETCH" (ssget) "")
 (command (setq basicpoint (getpoint "\n指定基点:")))
 (if (= nil s_dis_allyd)
(progn
 (setq s_dis_allyd movedis)
 (command s_dis_allyd)
)
(progn
 (setq s_disyd (getreal (strcat "\n输入拉伸距离<" (rtos s_dis_allyd 2 4)
 ">:"
 )
 )
 )
 (if (= nil s_disyd)
(setq s_disyd movedis)
 )
 (command s_disyd)
 (setq s_dis_allyd s_disyd)
)
 )
)
(setvar "ORTHOMODE" 0)
(princ "\***>>>>>End of 选字拉伸<<<<<***")
(princ)
 )

wxa123wl · 发表于 2014-4-3 02:32:36

st788796 发表于 2014-3-31 00:22

不可以呀呀！而且我还是加载不了晓东，加载了打开键就不起作用了！

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

[编程申请] 求一个改进的拉伸，移动lisp

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

点评