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

kucha007 · 发表于 2024-2-24 12:16:21

本帖最后由 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-2-24 14:01:34

本帖最后由 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的只要是填充就生成边界

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)

yoyrtweq · 发表于 2024-11-9 10:23:36

本帖最后由 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)
)

lingduwx · 发表于 2024-2-24 14:45:13

顶一个，好东西就要马上使用

wangsr · 发表于 2024-2-24 14:49:39

谢谢分享。

Eula · 发表于 2024-2-24 18:03:01

这个挺好用的，支持一下

atone · 发表于 2024-2-24 18:16:11

好工具，赞

a405692168 · 发表于 2024-2-24 20:52:46

膜拜大神！~~~

skyoo · 发表于 2024-2-24 22:10:05

感谢楼主不断更新，不断优化

magicheno · 发表于 2024-2-24 23:45:16

感谢大佬分享

yefei812678 · 发表于 2024-2-25 08:16:59

那个好用啊？

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

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

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐:

本帖子中包含更多资源

评分