本帖最后由 langjs 于 2014-8-24 21:39 编辑
很久以前写了一个块拉伸程序，缺点是每次只能拉伸一个块。现在改进一下可以同时拉伸多个块和其它图元。
不大喜欢块编辑器和参照，直接拉拉改改块觉得方便些。
刚刚修改一个小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)
)
网友答: cad2020 X64 调用(*push-error-using-command*)前无法从 *error* 调用(command)。
建议将(command)调用转换为(command-s)。
选择对象: 指定对角点: 找到 2 个网友答: 无法使用
调用(*push-error-using-command*)前无法从 *error* 调用(command)。
建议将(command)调用转换为(command-s)。网友答: 非常实用的工具。。。网友答: 不错的东西网友答: 谢谢郎大师！
网友答:
看看。谢谢。
网友答:
这个超实用的，感谢啦！网友答:
谢谢,郎大师写的程序超实用网友答:
支持支持，感谢分享
网友答: 学习一下，谢谢分享。网友答: 谢谢。。。。。。。。。。
很久以前写了一个块拉伸程序，缺点是每次只能拉伸一个块。现在改进一下可以同时拉伸多个块和其它图元。
不大喜欢块编辑器和参照，直接拉拉改改块觉得方便些。
刚刚修改一个小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)
)
网友答: cad2020 X64 调用(*push-error-using-command*)前无法从 *error* 调用(command)。
建议将(command)调用转换为(command-s)。
选择对象: 指定对角点: 找到 2 个网友答: 无法使用
调用(*push-error-using-command*)前无法从 *error* 调用(command)。
建议将(command)调用转换为(command-s)。网友答: 非常实用的工具。。。网友答: 不错的东西网友答: 谢谢郎大师！
网友答:
看看。谢谢。网友答:
这个超实用的，感谢啦！网友答:
谢谢,郎大师写的程序超实用网友答:
支持支持，感谢分享网友答: 学习一下，谢谢分享。网友答: 谢谢。。。。。。。。。。