[原创]块拉伸程序，模拟stretch（拉伸）命令对块进行拉伸

langjs · 发表于 2011-3-17 10:42:45

本帖最后由 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"))))
)

chenry676 · 发表于 2021-1-28 18:27:16

浩辰无法使用不知道什么原因，使用后消失图像。

a880110 · 发表于 2019-12-20 10:14:27

楼主这个问题是怎么解决的啊，我现在也遇到了

断箭 · 发表于 2018-4-22 08:43:06

比refedit在位编辑块，总体来讲，效率是提高了

qcw911 · 发表于 2011-3-17 10:59:05

有没有动态图片展示一下啊
刚才下了不会用啊

hdlyt11 · 发表于 2011-3-17 11:00:35

非常不错，第一次看到这种程序

langjs · 发表于 2011-3-17 11:43:16

本帖最后由 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)
)

yansu · 发表于 2011-3-17 13:42:34

2006、2010运行后直接返回命令行，不知是什么原因

cxs259 · 发表于 2011-3-17 13:51:29

cad2008加载后，也遇上楼上问题

qcw911 · 发表于 2011-3-17 14:12:19

2007加载后出现楼上问题

mmmmmm · 发表于 2011-3-17 15:19:19

根本没必要编程，直接用块在位编辑就行。

lrd1861 · 发表于 2011-3-17 19:37:07

这个不错支持一下

slzlfs · 发表于 2011-3-17 20:45:04

直接 REFEDIT 命令就搞定了嘛

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

[原创]块拉伸程序，模拟stretch（拉伸）命令对块进行拉伸

评分

本帖子中包含更多资源