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

xfjiamy

能不能增加属性块拉伸呀

Aries

再见熊猫衣服

“动态块”，08版CAD就有了。
了解一下。。

paulpipi

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

zj20190405

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

zj20190405 发表于 2020-2-19 15:39
;;; ==================================================================
;;;     扩展stretch拉伸命令 ...

修改了下，删除选定块拉伸之后重复一个块

cq4920

zj20190405 发表于 2020-2-19 15:39
;;; ==================================================================
;;;     扩展stretch拉伸命令 ...

希望默认是对单独块拉伸   如果当前线形是其他 拉伸后块内线形也会变化

cq4920

zj20190405 发表于 2020-2-19 15:40
修改了下，删除选定块拉伸之后重复一个块

批量拉伸会丢失被拉伸的块！单块拉伸又会多出一个块！还是没研究出来怎么处理！

magicheno

拉伸块了后，块丢失了不知道啥情况呢

陈伟

tian4185tt 发表于 2017-12-21 21:41
令: KLS
选择对象:
指定基点

确实有这个错误，CAD2020