【S】填充拉伸_v8.4——支持记忆拉伸

00放飞梦想00 · 发表于 2024-6-19 22:17:48

kucha007 发表于 2024-2-24 14:01
20240316_v8.2
1-修复了多次选择，后选的对象不会拉伸而是变为移动的bug
2-改写了获取块在位编辑时，是否 ...

选择的图形不在窗口范围内拉伸有问题

tensir · 发表于 2024-6-30 15:05:18

感谢作者的分享！

zhangcn · 发表于 2024-8-27 21:18:10

精简填充拉伸_v8.2 （仅保留记忆拉伸）
楼主的代码功能强大，但在浩辰始终不太好用，所以有了精简的想法，只保留记忆拉伸。
但也还是有问题，当画图到一定步骤后，执行这段记忆拉伸功能时，会卡住
有懂的朋友帮看看，只保留记忆拉伸功能，这段代码还能精简哪些代码。

;;; 精简填充拉伸_v8.2 （仅保留记忆拉伸）
;;; 填充拉伸_v8.2——支持记忆拉伸原贴：http://bbs.mjtd.com/thread-189485-1-1.html
(if (null vlax-dump-object) (vl-load-com))
(defun C:SVV (/ CurDoc *Old_SysVar* SS e0 XX BoxLst1 BoxLst2 TmpSS SSRE K:SSRedo4Redit K:STRETCH4SS)
(setq CurDoc (vla-get-ActiveDOCument (vlax-get-acad-object)))
(defun *error* (msg)
(if *Old_SysVar* (foreach xx *Old_SysVar* (apply 'setvar xx))) ;参数恢复
(princ "\n拉伸退出!\n")
(vla-endundomark CurDoc) ;错误时结束编组
)
(progn ;基础函数1
(defun K:SS->EntLst (SS / i EntLst) ;选择集转图元表@LeeMac
(if SS
(repeat (setq i (sslength SS))
(setq EntLst (cons (ssname SS (setq i (1- i))) EntLst))
)
)
)
(defun K:Lst->STR (Lst Del / STR) ;使用分隔符串联字符串@LeeMac
(setq STR (car Lst))
(foreach itm (cdr Lst) (setq STR (strcat STR Del itm)))
STR
)
)
(progn ;基础函数2
(defun K:SSRedo4Redit (SS / AcProNam XX) ;重新获取选择集,避免外部参照出错
(if
(and
(not (null (getvar "RefEditName"))) ;在位编辑ing
)
(progn
(ssget "P") ;重新获取选择集
)
SS
)
SS
)
(defun K:STRETCH4SS (SS / NoZero FstPT NxtPT a b XX) ;拉伸程序改写，支持空格默认@Kucha
(if (not Global:STRMvTyp) (setq Global:STRMvTyp 1)) ;1基点-1位移
(if (not Global:STRBsePT) (setq Global:STRBsePT (list 0.0 0.0 0.0))) ;默认位移量为0
(setq NoZero (not (vl-every '(lambda (a b) (equal a b 0.001)) Global:STRBsePT (list 0.0 0.0 0.0)))) ;不为0.0
(if (not (null SS)) ;选择集不为空
(progn
(if NoZero
(princ
(strcat
"\n空格为默认位移量(相对于UCS原点)"
(K:Lst->STR (mapcar '(lambda (xx) (rtos xx 2 1)) Global:STRBsePT) ", ")
">"
)
)
)
(while ;get*
(progn
(initget "F S") ;关键词
(setq FstPT (getpoint
(if (eq 1 Global:STRMvTyp) ;1基点-1位移
(strcat "\n指定基点,反向(F)/切换(S)")
(strcat "\n输入拉伸值,反向(F)/切换(S)")
)
)
)
(cond
((and (eq (type FstPT) 'STR) (eq (strcase FstPT) "F")) ;字母Ff
(if NoZero
(progn
(setq Global:STRBsePT (mapcar '(lambda (XX) (* -1 XX)) Global:STRBsePT))
(command "_.STRETCH" SS "" "non" (list 0.0 0.0 0.0) "non" Global:STRBsePT)
(princ "\n拉伸值反向,拉伸完毕!\n")
Nil ;退出循环
)
(progn
(princ "\n拉伸值为零,无法反向拉伸\n")
T ;继续循环
)
)
)
((and (eq (type FstPT) 'STR) (eq (strcase FstPT) "S")) ;字母Ss
(if (eq 1 (setq Global:STRMvTyp (* -1 Global:STRMvTyp)))
(princ "\n拉伸模式为基点\n")
(princ "\n拉伸模式为位移\n")
)
T ;继续循环
)
((not FstPT) ;空格回车使用位移(如果有)
(if NoZero
(progn
(command "_.STRETCH" SS "" "non" (list 0.0 0.0 0.0) "non" Global:STRBsePT)
(princ "\n拉伸完成!\n")
Nil ;退出循环
)
T ;继续循环
)
)
((and FstPT (eq (type FstPT) 'LIST)) ;指定了点
(if (eq 1 Global:STRMvTyp) ;1基点-1位移
(progn
(princ "\n注:此时不要空格") ;换行
(command "_.STRETCH" SS "" "non" FstPT pause)
(setq Global:STRBsePT (mapcar '- (getvar "lastpoint") FstPT)) ;更新位移量
(princ "\n拉伸完成!\n")
)
(progn
(setq Global:STRBsePT FstPT) ;更新位移量
(command "_.STRETCH" SS "" "non" (list 0.0 0.0 0.0) "non" FstPT)
(princ "\n拉伸完成!\n")
)
)
Nil ;退出循环
)
(T
(princ "\n拉伸退出!\n")
Nil ;退出循环
)
)
)
)
)
)
(princ)
)
)
(while (eq 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark CurDoc)
) ;关闭以前的编组
(vla-startundomark CurDoc)
(setq Old_SysVar '()) ;清空变量,避免出错
(setq Old_SysVar (mapcar
'(lambda (a / b)
(if (setq b (getvar (car a)))
(progn
(apply 'setvar a)
(list (car a) b)
)
)
)
(list
;;(list "CECOLOR" "bylayer") ;颜色红色
;;(list "PICKSTYLE" 0) ;忽略编组选择
(list "DIMZIN" 0) ;实数不消零
(list "CMDECHO" 0) ;关闭回显
)
)
) ;记录参数
(if (setq SS (K:SSRedo4Redit (ssget)))
(K:STRETCH4SS SS) ;带记忆拉伸
)
(command "redraw")
(if Old_SysVar (foreach xx Old_SysVar (apply 'setvar xx))) ;参数恢复
(vla-endundomark CurDoc)
(princ)
)
(princ)

;;; 精简填充拉伸_v8.2 （仅保留记忆拉伸） 
;;; 填充拉伸_v8.2——支持记忆拉伸原贴：http://bbs.mjtd.com/thread-189485-1-1.html 
 
(if (null vlax-dump-object) (vl-load-com)) 
(defun C:SVV (/ CurDoc *Old_SysVar* SS e0 XX BoxLst1 BoxLst2 TmpSS SSRE K:SSRedo4Redit K:STRETCH4SS) 
  (setq CurDoc (vla-get-ActiveDOCument (vlax-get-acad-object))) 
  (defun *error* (msg) 
    (if *Old_SysVar* (foreach xx *Old_SysVar* (apply 'setvar xx))) ;参数恢复 
    (princ "\n拉伸退出!\n") 
    (vla-endundomark CurDoc) ;错误时结束编组 
  ) 
  (progn  ;基础函数1 
    (defun K:SS->EntLst (SS / i EntLst)  ;选择集转图元表@LeeMac 
      (if SS 
        (repeat (setq i (sslength SS)) 
          (setq EntLst (cons (ssname SS (setq i (1- i))) EntLst)) 
        ) 
      ) 
    ) 
 
    (defun K:Lst->STR (Lst Del / STR)  ;使用分隔符串联字符串@LeeMac 
      (setq STR (car Lst)) 
      (foreach itm (cdr Lst) (setq STR (strcat STR Del itm))) 
      STR 
    ) 
  ) 
 
  (progn  ;基础函数2 
    (defun K:SSRedo4Redit (SS / AcProNam XX)  ;重新获取选择集,避免外部参照出错 
      (if 
        (and 
          (not (null (getvar "RefEditName"))) ;在位编辑ing 
        ) 
        (progn 
          (ssget "P") ;重新获取选择集 
        ) 
        SS 
      ) 
      SS 
    ) 
 
    (defun K:STRETCH4SS (SS / NoZero FstPT NxtPT a b XX)  ;拉伸程序改写，支持空格默认@Kucha 
      (if (not Global:STRMvTyp) (setq Global:STRMvTyp 1)) ;1基点-1位移 
      (if (not Global:STRBsePT) (setq Global:STRBsePT (list 0.0 0.0 0.0))) ;默认位移量为0 
      (setq NoZero (not (vl-every '(lambda (a b) (equal a b 0.001)) Global:STRBsePT (list 0.0 0.0 0.0)))) ;不为0.0 
      (if (not (null SS))  ;选择集不为空 
        (progn 
          (if NoZero 
            (princ 
              (strcat 
                "\n空格为默认位移量(相对于UCS原点)" 
                (K:Lst->STR (mapcar '(lambda (xx) (rtos xx 2 1)) Global:STRBsePT) ", ") 
                ">" 
              ) 
            ) 
          ) 
          (while  ;get* 
            (progn 
              (initget "F S") ;关键词 
              (setq FstPT (getpoint 
                            (if (eq 1 Global:STRMvTyp)  ;1基点-1位移 
                              (strcat "\n指定基点,反向(F)/切换(S)") 
                              (strcat "\n输入拉伸值,反向(F)/切换(S)") 
                            ) 
                          ) 
              ) 
              (cond 
                ((and (eq (type FstPT) 'STR) (eq (strcase FstPT) "F")) ;字母Ff 
                 (if NoZero 
                   (progn 
                     (setq Global:STRBsePT (mapcar '(lambda (XX) (* -1 XX)) Global:STRBsePT)) 
                     (command "_.STRETCH" SS "" "non" (list 0.0 0.0 0.0) "non" Global:STRBsePT) 
                     (princ "\n拉伸值反向,拉伸完毕!\n") 
                     Nil ;退出循环 
                   ) 
                   (progn 
                     (princ "\n拉伸值为零,无法反向拉伸\n") 
                     T ;继续循环 
                   ) 
                 ) 
                ) 
                ((and (eq (type FstPT) 'STR) (eq (strcase FstPT) "S")) ;字母Ss 
                 (if (eq 1 (setq Global:STRMvTyp (* -1 Global:STRMvTyp))) 
                   (princ "\n拉伸模式为基点\n") 
                   (princ "\n拉伸模式为位移\n") 
                 ) 
                 T ;继续循环 
                ) 
                ((not FstPT) ;空格回车使用位移(如果有) 
                 (if NoZero 
                   (progn 
                     (command "_.STRETCH" SS "" "non" (list 0.0 0.0 0.0) "non" Global:STRBsePT) 
                     (princ "\n拉伸完成!\n") 
                     Nil ;退出循环 
                   ) 
                   T ;继续循环 
                 ) 
                ) 
                ((and FstPT (eq (type FstPT) 'LIST)) ;指定了点 
                 (if (eq 1 Global:STRMvTyp)  ;1基点-1位移 
                   (progn 
                     (princ "\n注:此时不要空格") ;换行 
                     (command "_.STRETCH" SS "" "non" FstPT pause) 
                     (setq Global:STRBsePT (mapcar '- (getvar "lastpoint") FstPT)) ;更新位移量 
                     (princ "\n拉伸完成!\n") 
                   ) 
                   (progn 
                     (setq Global:STRBsePT FstPT) ;更新位移量 
                     (command "_.STRETCH" SS "" "non" (list 0.0 0.0 0.0) "non" FstPT) 
                     (princ "\n拉伸完成!\n") 
                   ) 
                 ) 
                 Nil ;退出循环 
                ) 
                (T 
                 (princ "\n拉伸退出!\n") 
                 Nil ;退出循环 
                ) 
              ) 
            ) 
          ) 
        ) 
      ) 
      (princ) 
    ) 
  ) 
 
  (while (eq 8 (logand 8 (getvar 'undoctl))) 
    (vla-endundomark CurDoc) 
  ) ;关闭以前的编组 
  (vla-startundomark CurDoc) 
 
  (setq Old_SysVar '()) ;清空变量,避免出错 
  (setq Old_SysVar (mapcar 
                     '(lambda (a / b) 
                        (if (setq b (getvar (car a))) 
                          (progn 
                            (apply 'setvar a) 
                            (list (car a) b) 
                          ) 
                        ) 
                      ) 
                     (list 
 
                       ;;(list "CECOLOR" "bylayer") ;颜色红色 
                       ;;(list "PICKSTYLE" 0) ;忽略编组选择 
                       (list "DIMZIN" 0) ;实数不消零 
                       (list "CMDECHO" 0) ;关闭回显 
                     ) 
                   ) 
  ) ;记录参数 
 
  (if (setq SS (K:SSRedo4Redit (ssget))) 
    (K:STRETCH4SS SS) ;带记忆拉伸 
  ) 
 
  (command "redraw") 
  (if Old_SysVar (foreach xx Old_SysVar (apply 'setvar xx))) ;参数恢复 
  (vla-endundomark CurDoc) 
  (princ) 
) 
 
(princ)

arkun · 发表于 2024-8-28 17:52:42

感谢大佬分享

757292550 · 发表于 2024-8-29 11:12:54

填充拉伸什么下载不了LSP格式的

C哩C哩 · 发表于 2024-8-29 15:35:24

超级好用，特意过来感谢

757292550 · 发表于 2024-10-17 16:08:39

【S】填充拉伸_v8.2——支持记忆拉伸 LPS格式的能不能发我一份，我只下载了fas的，LPS显示我的权限不够下载不下来。跪求！！！邮箱23221287@qq.com

lxl304712346 · 发表于 2024-10-18 21:49:27

居然要特定用户组，等级这么久了还没提升起来，哎。

jierc · 发表于 2024-10-20 11:12:34

8.2测试如果拉伸过程按ESC取消后，会导致CAD出现问题，希望优化

haotaer · 发表于 2024-10-20 13:12:26

没权限啊，改

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

【S】填充拉伸_v8.4——支持记忆拉伸

本帖子中包含更多资源