能不能增加属性块拉伸呀
“动态块”，08版CAD就有了。
了解一下。。
感谢 langjs 大师分享程序,学习了!
;;; ==================================================================
;;; <块拉伸 V2.2> 扩展stretch拉伸命令，对含多个普通块选择集进行拉伸
;;; 原理是打散块，拉伸后重新建块，2.2版增加个设置功能
;;; 作者:langjs 命令:kls 日期:2017年11月9日
;;; ==================================================================
(defun c:s (/ #errkls $orr $sz1 bb dcl_pt dcl_re dclname ent f i j kname lst name pt pt1 pt2 pt3 pt4 pt5 ss ss1 ss2 xun)
(defun #errkls (s)
(command ".UNDO" "E") (command ".UNDO" "") (setq *error* $orr)
)
(defun emkunameblk (ss pt / i name); 生成无名块
(entmake (list '(0 . "block") '(2 . "*U") '(70 . 1) (cons 10 pt)))
(repeat (setq i (sslength ss)) (entmake (cdr (entget (ssname ss (setq i (1- i)))))))
(setq name (entmake '((0 . "ENDBLK"))))
(command "_.erase" ss "")
(entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))
name)
(setq $orr *error**error* #errkls )
(setvar "cmdecho" 0)
(command ".UNDO" "BE")
(setq lst '() ss2 (ssadd) xun t )
(while xun
(initget "S ")
(if (= (setq pt1 (getpoint "\n窗交对象:指定角点 [设置(S)]:")) "S")
(progn
(setq dclname (vl-filename-mktemp "KLS.dcl")f (open dclname "w"))
(write-line "KLS:dialog {" f)
(write-line " label = \"块拉伸 V2.2 \" ; " f)
(write-line ":boxed_radio_column {label = \"设置\";" f)
(write-line ":radio_button {label = \"同名图块同步拉伸\";key =\"e01\"; mnemonic = \"1\"; } " f)
(write-line ":radio_button {label = \"选定图块图元拉伸\";key = \"e02\"; } }" f)
(write-line " ok_cancel ; } " f)
(close f)
(setq dcl_re (load_dialog dclname))
(new_dialog "KLS" dcl_re "" dcl_pt)
(if $sz(set_tile "e02" "1") (set_tile "e01" "1"))
(action_tile "e01" "( setq$sz1 nil ) ")
(action_tile "e02" "( setq$sz1 t )")
(action_tile "accept" "(setq dcl_pt (done_dialog 2))")
(action_tile "cancel" "(setq dcl_pt (done_dialog 3))")
(setq bb (start_dialog))
(unload_dialog dcl_re)
(vl-file-delete dclname)
(if (= bb 2) (setq $sz $sz1))
)
(setq xun nil)
))
(if (not (atom pt1))
(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 (and (= (cdr (assoc 0 ent)) "INSERT") (not (assoc 66 ent)))
(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 (assoc 2 ent) ss1 (assoc 8 ent)) 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) kname (cdadr name))
(if (and
(<= (* (- (car pt3) (car pt1)) (- (car pt3) (car pt2))) 0)
(<= (* (- (cadr pt3) (cadr pt1)) (- (cadr pt3) (cadr pt2))) 0))
(setq pt3 (polar pt3 (angle pt4 pt5) (distance pt4 pt5))))
(if (or$sz(wcmatch kname "\*U*"))
(setq kname (emkunameblk (caddr name) pt3))
(command "block" kname "y" pt3 (caddr name) ""))
(entmake (list '(0 . "INSERT") (cons 2 kname) (cons 10 pt3) (cadddr name))))
(#errkls)
)))))
(setq e1 (entlast))
(command "ERASE" E1 "")
(command ".UNDO" "E")
(setq *error* $orr)
(princ)
)
zj20190405 发表于 2020-2-19 15:39
;;; ==================================================================
;;; 扩展stretch拉伸命令 ...
修改了下，删除选定块拉伸之后重复一个块
本帖最后由 cq4920 于 2020-4-12 21:59 编辑
zj20190405 发表于 2020-2-19 15:39
;;; ==================================================================
;;; 扩展stretch拉伸命令 ...
希望默认是对单独块拉伸 如果当前线形是其他 拉伸后块内线形也会变化
zj20190405 发表于 2020-2-19 15:40
修改了下，删除选定块拉伸之后重复一个块
批量拉伸会丢失被拉伸的块！单块拉伸又会多出一个块！还是没研究出来怎么处理！
拉伸块了后，块丢失了不知道啥情况呢
tian4185tt 发表于 2017-12-21 21:41
令: KLS
选择对象:
指定基点
确实有这个错误，CAD2020