块拉伸2.0.LSP

langjs

很久以前写了一个块拉伸程序，缺点是每次只能拉伸一个块。现在改进一下可以同时拉伸多个块和其它图元。
不大喜欢块编辑器和参照，直接拉拉改改块觉得方便些。
刚刚修改一个小BUG


;;; ================================================================
;;; <块拉伸2.0>    扩展stretch拉伸命令，可对含多个块的选择集进行拉伸
;;; 作者:langjs    命令:kls 　          日期:2014年8月12日
;;; ================================================================
(defun c:kls (/ #errkls $orr ent i j lst name pt1 pt2 pt3 pt4 pt5 ss ss1 ss2)
  (defun #errkls (s)
    (command ".UNDO" "E")
    (command ".UNDO" "")
    (setq *error* $orr))
  (setq $orr *error* *error* #errkls)
  (setvar "cmdecho" 0)
  (command ".UNDO" "BE")
  (setq lst '() ss2 (ssadd))
  (if (setq pt1 (getpoint "\n窗交对象:指定角点:"))
    (if (setq pt2 (getcorner pt1 "\n窗交对象:指定对角点:"))
      (if (setq ss (ssget "c" pt1 pt2))
        (progn
          (repeat (setq i (sslength ss))
            (setq name (ssname ss (setq i (1- i))) ent (entget name))
            (if (= (cdr (assoc 0 ent)) "INSERT")
              (progn
                (setq pt3 (cdr (assoc 10 ent)))
                (entmake (list '(0 . "POINT") (cons 10 pt3)))
                (ssadd (entlast) ss2)
                (command ".explode" name)
                (setq ss1 (ssget "p")lst (cons (list pt3 (cdr (assoc 2 ent)) ss1) lst))
                (repeat (setq j (sslength ss1))(redraw (ssname ss1 (setq j (1- j))) 3)))
              (redraw name 3)))
          (sssetfirst nil ss2)
          (while (not (setq pt4 (getpoint "\n指定基点:"))))
          (command "erase" ss2 "")
          (princ "\n指定第二个点,或相对基点位移:")
          (command "_.stretch" "c" pt1 pt2 "" pt4 pause)
          (setq pt5 (getvar "lastpoint"))
          (if (/= (distance pt4 pt5) 0.0)
            (repeat (setq i (length lst))
              (setq name (nth (setq i (1- i)) lst ) pt3 (car name))
              (if (and
                    (<= (min (car pt1) (car pt2)) (car pt3) (max (car pt1) (car pt2)))
                    (<= (min (cadr pt1)(cadr pt2))(cadr pt3)(max (cadr pt1)(cadr pt2))))
                (setq pt3 (polar pt3 (angle pt4 pt5) (distance pt4 pt5))))
              (command "block" (cadr name) "y" pt3 (caddr name) "")
              (entmake (list '(0 . "INSERT") (cons 2 (cadr name)) (cons 10 pt3))))
            (#errkls))))))
  (command ".UNDO" "E")
  (setq *error* $orr)
  (princ)
)

594826903

cad2020 X64 调用(*push-error-using-command*)前无法从 *error* 调用(command)。
建议将(command)调用转换为(command-s)。
选择对象: 指定对角点: 找到 2 个

moranyuyan

无法使用
调用(*push-error-using-command*)前无法从 *error* 调用(command)。
建议将(command)调用转换为(command-s)。

edata

非常实用的工具。。。

cable2004

不错的东西

lucas_3333

谢谢郎大师！

xchj81

看看。谢谢。

Atsai

这个超实用的，感谢啦！

sdflq

谢谢,郎大师写的程序超实用

aihuyujian

支持支持，感谢分享

恕放之生命

学习一下，谢谢分享。

shengyulon

谢谢。。。。。。。。。。