kucha007 发表于 2024-2-24 14:01
20240316_v8.2
1-修复了多次选择，后选的对象不会拉伸而是变为移动的bug
2-改写了获取块在位编辑时，是否 ...
选择的图形不在窗口范围内拉伸有问题
感谢作者的分享！
精简填充拉伸_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)
感谢大佬分享
填充拉伸什么下载不了LSP格式的
超级好用，特意过来感谢
【S】填充拉伸_v8.2——支持记忆拉伸LPS格式的能不能发我一份，我只下载了fas的，LPS显示我的权限不够下载不下来。跪求！！！邮箱23221287@qq.com
居然要特定用户组，等级这么久了还没提升起来，哎。
8.2测试如果拉伸过程按ESC取消后，会导致CAD出现问题，希望优化
没权限啊， 改