[原创]块拉伸程序，模拟stretch（拉伸）命令对块进行拉伸
本帖最后由 langjs 于 2012-2-9 01:11 编辑修订了下面的这种错误
*无效选择*
需要点或窗口(W)/上一个(L)/窗交(C)/框(BOX)/全部(ALL)/栏选(F)/圈围(WP)/圈交(CP)/编组(G)/添加(A)/删除(R)/多个(M
)/前一个(P)/放弃(U)/自动(AU)/单个(SI)/子对象(SU)/对象(O)
; 错误: *error* 函数中出错函数被取消
;;; =================================================================
;;; 块拉伸程序，模拟stretch（拉伸）命令对块拉伸
;;; 作者：langjs 命令：KLS 日期2011年3月16日
;;; =================================================================
(defun C:KLS (/ $orr en ent i kming pt1 pt2 pt3 pt4 pt5 ptls slen ss)
(setq $orr *error*)
(setq *error* #err1) ; 当程序出错时就会执行#err函数
(setvar "cmdecho" 0) ; 关闭命令响应
(command ".UNDO" "BE") ; 设置UNDO起点
(while (not (and
(setq ss (SSsel))
(= (sslength ss) 1)
)
)
) ; 选择一个要拉伸的块
(setq ent (entget (ssname ss 0))) ; 块属性
(setq PT3 (cdr (assoc 10 ent))) ; 取得块的插入点
(setq kming (cdr (assoc 2 ent))) ; 取得块的名称
(command ".explode" ss"") ; 打散图块
(setq ss (ssget "p")) ; 获取打散图块图元选择集
(command ".point" PT3) ; 画块的插入点标识
(setq ptls (entlast))
(sssetfirst nil (ssadd ptls (ssadd))) ; 夹点亮显块的插入点
(setq slen (sslength ss)
i 0
)
(while (ssname ss i)
(setq ent (ssname ss i))
(redraw ent 3) ; 亮显选择集
(setq i (+ 1 i))
)
(while (not (setq pt4 (getpoint "\n指定基点")))) ; 拉伸起点
(princ "\n指定第二个点或 <使用第一个点作为位移>:")
(command "erase" ptls "") ; 删除块插入点标识
(command "_.stretch" "c" pt1 PT2 "" pt4 pause) ; 拉伸啦
(setq PT5 (getvar "lastpoint")) ; 拉伸终点
(if (and
(>= (car pt1) (car pt3))
(<= (car pt2) (car pt3))
(<= (cadr pt1) (cadr pt3))
(>= (cadr pt2) (cadr pt3))
)
(setq PT3 (list (+ (car PT3) (- (car PT5) (car pt4))) (+ (cadr PT3) (- (cadr PT5) (cadr pt4)))))
(princ)
) ; 如果块插入点在拉伸框选范围内，则计算插入点到拉伸后的位置
(command "block" kming "y" PT3 ss "") ; 将拉伸后的图元选择集做成块并替换原来的块
(command "INSERT" kming PT3 1 1 0) ; 插入块，将刚刚拉伸的块显示出来。
(command ".UNDO" "E") ; 设置UNDO终点
(setq *error* $orr)
(princ)
)
;;; 出错处理函数
(defun #err1 (s)
(command ".UNDO" "E") ; 设置UNDO终点
(command ".UNDO" "") ; 后退一步
(princ )
(setq *error* $orr)
)
;;; 选择集选择
(defun SSsel (/)
(princ "\n选择对象:")
(setq pt1 (ptsel)) ; 框选起点
(command "rectang" PT1 pause) ; 绘制辅助框
(setq name (entlast)) ; 辅助框名称
(setq PT2 (getvar "lastpoint")) ; 框选终点
(command "erase" name "") ; 删除辅助框
(ssget "c" pt1 PT2 '((0 . "insert"))) ; 将辅助框相交的图块做成选择集
)
;;; 选点变框函数;论坛某老大提供的函数
(defun ptsel (/ len pt pt1 x y)
(while (not (member (car (setq pt1 (grread t 12 2))) '(3 2 11)))
(setq pt1 (cadr pt1))
(if (vl-consp pt1)
(progn
(or
pt
(setq pt pt1)
)
(setq x (car pt)
y (cadr pt)
)
(if (> (distance pt1 pt) (p2u222 (* 0.0001 (car (getvar "screensize")))))
(progn
(redraw)
(setq len (p2u222 1)
x (car pt)
y (cadr pt)
)
(setq pt pt1)
)
)
)
)
)
pt
)
(defun p2u222 (pix)
(* pix (/ (getvar "viewsize") (cadr (getvar "screensize"))))
)
浩辰无法使用不知道什么原因，使用后消失图像。 楼主这个问题是怎么解决的啊，我现在也遇到了 比refedit在位编辑块，总体来讲，效率是提高了 有没有动态图片展示一下啊
刚才下了不会用啊 非常不错，第一次看到这种程序 本帖最后由 langjs 于 2012-2-9 01:09 编辑
回复 qcw911 的帖子
截图，使用方法和stretch（拉伸）命令一样
;;; =================================================================
;;; 块拉伸程序，模拟stretch（拉伸）命令对块拉伸
;;; 作者：langjs 命令：kls 日期2012年2月1日
;;; =================================================================
(defun c:kls (/ $orr ent i kming pt1 pt2 pt3 pt4 pt5 ptls ss)
(defun #err1001 (s) ; 出错处理函数
(command ".UNDO" "E")
(command ".UNDO" "")
(princ)
(setq *error* $orr)
)
(setq $orr *error*)
(setq *error* #err1001) ; 当程序出错时就会执行#err函数
(setvar "cmdecho" 0) ; 关闭命令响应
(command ".UNDO" "BE") ; 设置undo起点
(while (not (and
(setq ss (progn
(setq pt1 (getpoint "\n指定一个角点:")) ; 框选起点
(setq pt2 (getcorner pt1 "\n指定第二个角点:"))
(ssget "c" pt1 pt2 '((0 . "insert"))) ; 将辅助框相交的图块做成选择集
)
)
(= (sslength ss) 1)
)
)
) ; 选择一个要拉伸的块
(setq ent (entget (ssname ss 0))
pt3 (cdr (assoc 10 ent)) ; 块插入点
kming (cdr (assoc 2 ent)) ; 块名
)
(command ".explode" ss "") ; 打散块
(setq ss (ssget "p")) ; 获取打散块图元选择集
(command ".point" pt3) ; 画块的插入点标识
(setq ptls (entlast))
(sssetfirst nil (ssadd ptls (ssadd))) ; 夹点亮显块的插入点
(repeat (setq i (sslength ss))
(redraw (ssname ss (setq i (1- i))) 3)
)
(while (not (setq pt4 (getpoint "\n指定基点")))) ; 拉伸起点
(entdel ptls) ; 删除块插入点标识
(princ "\n指定第二个点或 <使用第一个点作为位移>:")
(command "_.stretch" "c" pt1 pt2 "" pt4 pause) ; 拉伸啦
(setq pt5 (getvar "lastpoint")) ; 拉伸终点
(if (and
(>= (car pt1) (car pt3))
(<= (car pt2) (car pt3))
(<= (cadr pt1) (cadr pt3))
(>= (cadr pt2) (cadr pt3))
)
(setq pt3 (list (+ (car pt3) (- (car pt5) (car pt4))) (+ (cadr pt3) (- (cadr pt5) (cadr pt4)))))
) ; 如果块插入点在拉伸框选范围内，则计算插入点到拉伸后的位置
(command "block" kming "y" pt3 ss "") ; 做块
(command "INSERT" kming pt3 1 1 0) ; 插入块
(command ".UNDO" "E") ; 设置undo终点
(setq *error* $orr)
(princ)
)
2006、2010运行后直接返回命令行，不知是什么原因 cad2008加载后，也遇上楼上问题 2007加载后出现楼上问题 根本没必要编程，直接用块在位编辑就行。 这个不错支持一下 直接REFEDIT命令就搞定了嘛