块拉伸2.2.LSP增加个简单设置功能
;;; ==================================================================;;; <块拉伸 V2.2> 扩展stretch拉伸命令，对含多个普通块选择集进行拉伸
;;; 原理是打散块，拉伸后重新建块，2.2版增加个设置功能
;;; 作者:langjs 命令:kls 日期:2017年11月9日
;;; ==================================================================
(defun c:kls (/ #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)
)))))
(command ".UNDO" "E")
(setq *error* $orr)
(princ)
)
zj20190405 发表于 2020-2-19 15:39
;;; ==================================================================
;;; 扩展stretch拉伸命令 ...
如果用(command ".explode" name)炸开块，有点卡顿，我试了一下，
删除 (redraw (ssname ss1 (setq j (1- j))) 3) 和 (redraw name 3)这两句话， 也就是不亮显刚炸开的块，就可以避免卡顿。
另外，如果用vla-explode炸开块，也可以避免卡顿，但我还不会用vla-explode去修改。希望高手来修改一下。 同楼上
命令: KLS
窗交对象:指定角点 [设置(S)]:
窗交对象:指定对角点:
指定基点:
指定第二个点,或相对基点位移:
*无效选择*
需要点或 窗口(W)/上一个(L)/窗交(C)/框(BOX)/全部(ALL)/栏选(F)/圈围(WP)/圈交(CP)/编组(G)/添加(A)/删除(R)/多个(M)/前一个(P)/放弃(U)/自动(AU)/单个(SI)/子对象(SU)/对象(O)
原因：函数被取消 位置-> 行:68 列:12
选择对象: *取消* ;;; ==================================================================
;;; <块拉伸 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)
) 一进来就看到大师的杰作，收藏了，谢谢。 感谢 langjs 大师分享程序,学习了! 很好的程序，我一直用得着这个程序，感谢狼大师！ 这个功能，牛，大师棒 不能用啊，拉伸块就散了
我在07里试的，可以用 貌似不太会用，有个gif就好了 不错，就是怎么只能在俯视图里使用呢