【S】填充拉伸_v8.4——支持记忆拉伸
本帖最后由 kucha007 于 2024-11-12 13:15 编辑旧贴在这里：http://bbs.mjtd.com/forum.php?mod=viewthread&tid=186418&page=1&extra=#pid928863
一直想再改写这个程序，但之前对复杂表的处理总是不得要点。前段时间梳理了填充生成边界，这加强了我对表的理解。
所以这回是在重新理解了ssnamex的基础上，几乎是推到重来了。本程序和之前的版本不同的点主要有这些：
1-增强原拉伸命令，记录位移量。空格使用上一次位移量进行拉伸
(位移量是相对于UCS原点)
(记忆拉伸增加反向拉伸的操作)
2-增加对其它选择方式的兼容，收集包含点选和栏选产生的对象。使其更接近原生的拉伸命令
(这里收集的对象，拉伸时表现为移动)
已知可能出错的情况:
在位编辑的设置中，可以锁定不在工作集中的所有对象
当这个选项被勾选且正在编辑参照时，如果仅选择不在工作集中的对象，且这部分对象包含填充HATCH，则会因为无法生成填充轮廓而造成错误。
lisp不知道怎么判断对象不在工作集中（有大佬知道可以分享一下），目前只能是尽量增加判断来避免出现这种情况了
不过这个选项默认是锁定的，非锁时就没问题了。一般也不会在编辑参照的时候仅去拉伸不在工作集中的对象吧?
可能会误认为出错的情况:
该程序的原理是生成填充的轮廓并且关联，然后再重新框选进行拉伸。
所以第一步就要解除填充与旧边界的关联，从而使得新生成的边界可以和填充关联，以便关联拉伸
拉伸后新的填充边界被删除，填充也就不再和任何边界关联。
也就是说原来关联的填充拉伸后将不再关联，看起来就像出错了一样。
但是，这不是错误!!! 这不是错误!!! 这不是错误!!!
况且这个程序是带填充拉伸，所以填充是否关联也不重要了吧？
本帖最后由 kucha007 于 2024-3-16 00:53 编辑
20240316_v8.2
1-修复了多次选择，后选的对象不会拉伸而是变为移动的bug
2-改写了获取块在位编辑时，是否锁定外部对象的选项值。以便判断是否重构选择集
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=189614&fromuid=7329538
20240204——此版本不再更新，可能有bug
尝试过滤掉关联填充，只生成非关联填充的边界，使得拉伸前关联的填充，拉伸后仍然保持关联。
但是可能会出错，例如删除了关联的边界却仍然保持关联的填充将无法拉伸。
这时可以先原位移动一下这部分填充再用拉伸命令，我个人还是喜欢v8.1的只要是填充就生成边界
本帖最后由 yoyrtweq 于 2024-11-9 11:18 编辑
这也是论坛里大佬写的，这个比群主精简点，但产生的填充边界稍微慢点和没有拉伸预览。但这个胜在与拉伸出数值后，直接框选后往左往右都可以按照拉伸数值走，但群主的往左就只能往左，必须在设置中反向才能往右。能否结合各家的优点进行优化。提升效率一些。优化下代码上取消反向，直接框选后往左往右都可以按照拉伸数值走呢。
(defun C:S( )
(setq old_lay (getvar "clayer")) ;保存当前图层
(setq layer "填充边界线")
(if (not (tblsearch "layer" layer ))
(progn (command "layer" "new" "填充边界线" "s" "填充边界线" "C" 5 "" "L" "Continuous" "" "P" "N" "" "Tr" "90" "" "LW" 0"" "") ));新建图层
(setvar "clayer" old_lay) ;恢复原先图层
(princ "\n请选择：除第一个选择框外，其他选择框中的非关联填充图案不会被拉伸")
(setq xyxyxy (last (ssnamex (setq ss (ssget ":S" )) 0)));;选择需要拉伸的填充图案或者其他图元，获得ssget选择集的一个信息表。
(setq xt (last (cadr xyxyxy)) yt (last (cadddr xyxyxy))) ;;提取刚才的窗选对角坐标。
(setq xt (trans xt 0 1)
yt (trans yt 0 1)
)
(COMMAND "clayer" layer) ;置当前图层
(setq sg (ssget "P" '((0 . "HATCH")) ) i -1 );过滤对象只选填充图案
(if sg (while (setq s1 (ssname sg (setq i (1+ i))));批量生成填充边界
(command "-hatchedit" s1 "b" "p" "y")(setq sggg (ssget "A"'((8 . "填充边界线"))))(command "draworder" sggg "" "b" ) )) ;批量生成填充边界，选择边界线，后置边界线
(setvar "clayer" old_lay) ;恢复原先图层
(command "SELECT" "c" "non"xt "non"yt pause )
(command ".STRETCH""p""") ;;
(command (setq pt (getpoint "\n指定基点:")))
(IF (NULL *dd*) (setq *dd* 10))
(setq dd (getdist pt (strcat "\n输入拉伸距离<" (rtos *dd* 2 2) ">:")))
(if (NULL dd) (setq dd *dd*) (setq *dd* dd))
(command dd)
(if sg (while (COMMAND "_.erase"sggg "") ));删除生成的边界线！
(princ)
)
精简填充拉伸_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)
顶一个，好东西就要马上使用{:1_1:} 谢谢分享。 这个挺好用的，支持一下 好工具，赞 膜拜大神！~~~:loveliness: 感谢楼主不断更新，不断优化 感谢大佬分享 那个好用啊？