块拉伸2.2.LSP增加个简单设置功能

langjs · 发表于 2017-11-22 16:13:06

;;; ==================================================================
;;; <块拉伸 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)
)

qazxswk · 发表于 2022-2-11 16:20:58

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去修改。希望高手来修改一下。

clinber · 发表于 2017-11-23 17:40:56

同楼上

命令: KLS
窗交对象:指定角点 [设置(S)]:
窗交对象:指定对角点:
指定基点:
指定第二个点,或相对基点位移:

*无效选择*
需要点或窗口(W)/上一个(L)/窗交(C)/框(BOX)/全部(ALL)/栏选(F)/圈围(WP)/圈交(CP)/编组(G)/添加(A)/删除(R)/多个(M)/前一个(P)/放弃(U)/自动(AU)/单个(SI)/子对象(SU)/对象(O)

原因：函数被取消位置-> 行:68 列:12
选择对象: *取消*

zj20190405 · 发表于 2020-2-19 15:39:11

;;; ==================================================================
;;; <块拉伸 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)
)

sdbaijiao · 发表于 2017-11-22 16:34:01

一进来就看到大师的杰作，收藏了，谢谢。

yoyoho · 发表于 2017-11-23 07:09:05

感谢 langjs 大师分享程序,学习了!

USER2128 · 发表于 2017-11-23 08:16:05

很好的程序，我一直用得着这个程序，感谢狼大师！

天下逍遥 · 发表于 2017-11-23 10:02:17

这个功能，牛，大师棒

走走逛逛瞧瞧 · 发表于 2017-11-23 14:26:41

不能用啊，拉伸块就散了

逍遥天下 · 发表于 2017-11-24 10:31:36

我在07里试的，可以用

石井鱼 · 发表于 2017-11-24 20:04:23

貌似不太会用，有个gif就好了

864643236 · 发表于 2017-11-24 22:57:51

不错，就是怎么只能在俯视图里使用呢

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

[源码] 块拉伸2.2.LSP增加个简单设置功能

点评

评分