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

langjs

vlisp2012 发表于 2012-2-5 10:37
cad2011,无法使用啊！
*无效选择*
需要点或窗口(W)/上一个(L)/窗交(C)/框(BOX)/全部(ALL)/栏选(F)/圈围(W ...

用这个试试
;;; =================================================================
;;; 块拉伸程序，模拟stretch（拉伸）命令对块拉伸
;;; 作者：langjs   　　　　命令：tkls 　　　　　  日期2012年2月4日
;;; =================================================================
(defun c:tkls (/ $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)
)

zhengchuan

2012无法使用啊，直接炸开啦

cjjh8301

有用没有用都要支持下！

lincctw_ccl

不错的程序!!现在还用不到
作个标记先!谢谢楼主无私的分享!!

434939575

好资料。可惜2007上不能用。

teykmcqh

2006版测试通过，只对线框有效，暂时用不着，学习和支持一下源码！

空谷藏

说用参照的一看就是没画过大图的，一个重生成2分钟的伤不起啊

lovein2002

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

l64631778

langjs 发表于 2011-3-24 23:19
多个块拉伸存在逻辑问题，比如说：一张图纸上两个块块名一样，只是旋转角度不同，他们同时拉伸，拉伸后形 ...

YAD就可以多个块一起拉伸了

l64631778

多选之后，可以过滤掉同名块