超级动态调整
本帖最后由 20060510412 于 2022-5-7 20:28 编辑在既有源代码基础上进行了改进，源代码里面有原作者信息，在此表示感激。
1.支持对文字高度、标注比例、线型比例、填充比例、块缩放比例进行动态调整。
2.支持先选择对象后执行。
3.可以批量选择多个同类型图元（例如单行文本），然后同时动态调整这些文本的高度。ps：执行批量操作，需要首先选择所有的目标对象，然后再执行命令。
;;;duotu007 ver1.0 2012/9/6(原著)
;;;1028695446 ver2.0 2019/4/4(修改)
(defun c:tt (/ bl_update bl_update_time_batch boolean_typeofss ent error_do main_process main_process_batch ss text_update color text textent)
;启用错误处理之后，导致无法先选择后执行，具体原因还不得而知。
;(error_init 'error_do 1)
(defun error_do ()
(redraw)
(if text (entdel text));删除临时文字
(princ)
)
;;-------------------
(defun bl_update (tp bl);;子函数,更新比例为绝对值bl
(cond
((member tp '("REGION" "LWPOLYLINE" "LINE" "CIRCLE" "ARC"))
(vla-put-LinetypeScale obj bl);;设定线型比例
)
((= tp "HATCH")
(vla-put-PatternScale obj bl);;设定填充比例
)
((= tp "INSERT")
(vla-put-xscalefactor obj bl);;设定图块比例x
(vla-put-yscalefactor obj bl);;设定图块比例y
(vla-put-zscalefactor obj bl);;设定图块比例z
)
((member tp '("TEXT" "MTEXT"))
(vla-put-Height obj bl)
)
((wcmatch tp "*DIMENSION")
(vla-put-ScaleFactor obj bl)
)
)
)
;;---------------------------------
(defun bl_update_time_batch (list_ent list_bl bl / tp);;子函数,对选择集内的图元，批量更新比例为原始比例的bl倍
(setq tp (dxf1 (entget (nth 0 list_ent)) 0))
(cond
((member tp '("REGION" "LWPOLYLINE" "LINE" "CIRCLE" "ARC"))
(mapcar '(lambda (x y) (vla-put-LinetypeScale (en2obj x) (* y bl))) list_ent list_bl)
)
((= tp "HATCH")
(mapcar '(lambda (x y) (vla-put-PatternScale (en2obj x) (* y bl))) list_ent list_bl)
)
((= tp "INSERT")
(mapcar '(lambda (x y) (vla-put-xscalefactor (en2obj x) (* y bl))) list_ent (nth 0 list_bl))
(mapcar '(lambda (x y) (vla-put-yscalefactor (en2obj x) (* y bl))) list_ent (nth 1 list_bl))
(mapcar '(lambda (x y) (vla-put-zscalefactor (en2obj x) (* y bl))) list_ent (nth 2 list_bl))
)
((member tp '("TEXT" "MTEXT"))
(mapcar '(lambda (x y) (vla-put-Height (en2obj x) (* y bl))) list_ent list_bl)
)
((wcmatch tp "*DIMENSION")
;(vla-put-ScaleFactor obj bl)
(mapcar '(lambda (x y) (vla-put-ScaleFactor (en2obj x) (* y bl))) list_ent list_bl)
)
)
)
;;-------------------
(defun text_update (str / );;子函数,更新临时文字
(if color (princ) (setq color 1))
;(setq str (rtos bl))
(if text;文字显示
(progn
(setq textent (subst (cons 1 str) (assoc 1textent) textent))
(setq textent (subst (cons 62 color) (assoc 62 textent) textent))
(setq textent (subst (cons 40 (/ (getvar "viewsize") 30)) (assoc 40 textent) textent))
;鼠标移动的时候，更新坐标，使其跟随鼠标移动；敲击键盘的时候，不更新坐标
(if (= a 5) (setq textent (subst (cons 10 aa) (assoc 10 textent) textent)))
;(if flag_dynamic (setq textent (subst (cons 10 aa)(assoc 10 textent) textent)));启用动态比例
(entmod textent)
);第二遍已有,修改内容
(progn
(entmake
(list
'(0 . "TEXT")
(cons 1 str)
;鼠标移动的时候，更新坐标，使其跟随鼠标移动；其他情况，坐标为图元的坐标
(if (= a 5) (cons 10 aa) (cons 10 pt0))
;(if flag_dynamic (cons 10 aa)(cons 10 pt0))
(cons 40 (/ (getvar "viewsize") 30));;字体大小,同视图比例相关
(cons 41 0.7) ;;字高
(cons 50 0);;字旋转角度
(cons 62 color)
)
)
(setq text (entlast) textent (entget text))
);第一遍文字不存在先生成
)
)
;判断选择集是否均为同一图元类型----------
(defun boolean_typeOfSs (ss str_type / ent flag index tp)
(setq flag T)
(setq index 0)
(while (and flag (setq ent (ssname ss index)))
(setq tp (dxf1 (entget ent) 0))
(if
(not
(if (= str_type "*DIMENSION")
(wcmatch tp "*DIMENSION")
(= tp str_type)
)
)
(setq flag nil)
)
(setq index (1+ index))
)
flag
)
;针对单一图元的处理流程-----------
(defun main_process (ent pt0 / a aa bl color elist flag_circulate flag_dynamic flag_secondclick mouse tp obj point_base)
(setq elist (entget ent))
(setq tp (dxf1 elist 0))
(setq obj (en2obj ent))
(setq flag_dynamic nil);;默认启用动态比例
(setq flag_secondClick nil) ;第二次鼠标左键，结束程序
(cond
;获得标注的全局比例
((wcmatch tp "*DIMENSION")
(if (= (setq bl (vla-get-ScaleFactor (en2obj ent))) nil) (setq bl 1))
)
((member tp '("TEXT" "MTEXT")) ;取文字高度值作为实际比例
(if (= (setq bl (dxf1 elist 40)) nil)
(setq bl 1)
)
)
((member tp '("REGION" "LWPOLYLINE" "LINE" "CIRCLE" "ARC"))
(if (= (setq bl (dxf1 elist 48)) nil)
(setq bl 1)
)
)
((member tp '("HATCH" "INSERT"))
(setq bl (dxf1 elist 41) flag_dynamic nil)
);;注意,这要关闭,因为初始不能为0
(t (alert "\n 选择错误..."))
)
(if bl
(progn
(setq flag_circulate T)
(while flag_circulate
(setq mouse (grread T 12 0))
(setq a (car mouse) aa (cadr mouse))
(cond
;按键d或者D字高增加一倍
((and (= 2 a) (or (= 100 aa) (= 68 aa)));2表示键盘输入,'(2 100)表示d键,'(2 68)表示D键
(setq flag_dynamic nil);;关闭动态比例
(setq bl (* bl 2))
(bl_update tp bl)
(text_update (rtos bl));;更新文字
)
;按键w或者W字高缩小一倍
((and (= 2 a) (or (= 120 aa) (= 88 aa)));2表示键盘输入,'(2 120)表示x键,'(2 88)表示X键
(setq flag_dynamic nil);;关闭动态比例
(setq bl (/ bl 2))
;(if(= tp "INSERT")(if (< 0 (1- bl))(setq bl (1- bl)))(setq bl (/ bl 2)));;块单独区分,加减更适用
;(if (< bL 0.01)(setq bL 0.01));;防止比例为太杂****************************************
(bl_update tp bl)
(text_update (rtos bl));;更新文字
)
;按键e或者E指定比例
((and (= 2 a) (or (= 101 aa) (= 69 aa)))
(setq flag_dynamic nil);;关闭动态比例
(setq bl (getreal "\n 指定缩放比例:"))
(bl_update tp bl)
(text_update (rtos bl));;更新文字
)
((and (= a 5) flag_dynamic);鼠标移动和启用动态比例
(redraw)
(grdraw point_base aa 1);画向量
(setq bl (distance point_base aa))
(cond
((and (< 0 bl) (< bl 0.1))
(setq bl (* (fix (/ bl 0.01)) 0.01) color 1);规范0~1之间取值,模数=0.1
)
((and (<= 0.1 bl) (< bl 1))
(setq bl (* (fix (/ bl 0.1)) 0.1) color 2);规范0~1之间取值,模数=0.1
)
((and(<= 1 bl) (< bl 10))
(setq bl (* (fix (/ bl 0.5)) 0.5) color 3);规范1~10之间取值,模数=0.5
)
((and(<= 10 bl) (< bl 20))
(setq bl (fix bl) color 4);规范10~20之间取值,模数=1
)
((and(<= 20 bl) (< bl 100))
(setq bl (* (fix (/ bl 5)) 5) color 4);规范20~100之间取值,模数=5
)
((<= 100 bl)
(setq bl (* (fix (/ bl 10)) 10) color 6);规范20~100之间取值,模数=10
)
((= 0 bl) (setq bl 1 color 6))
)
(bl_update tp bl);;更新比例
(text_update (rtos bl));;更新文字
)
((and (= a 5) (not flag_dynamic));鼠标移动,不启用动态比例
(text_update (strcat "当前比例：" (rtos bl 2 2) "\n【放大(D)/缩小(X)/指定(E)/动态(左键)/退出(空格)】"));;更新文字
)
((= a 3);鼠标左键,启用动态比例
(setq flag_dynamic T)
(setq point_base aa)
(if (= flag_secondClick nil);识别第二次点击鼠标左键
(setq flag_secondClick T)
(setq flag_circulate nil)
)
)
((or
(= 25 a) (= 11 a) ;右键
(and (= a 2) (= aa 13));回车
(and (= a 2) (= aa 32));或空格
)
(setq flag_circulate nil)
)
)
)
)
(alert "\n 比例不能为0")
)
(redraw)
(if text (entdel text));删除临时文字
(princ)
)
;对选择集的批量处理，以相对的缩放倍数为基准
(defun main_process_batch (ss pt0 / a aa bl color flag_circulate flag_dynamic flag_secondclick list_bl list_ent mouse tp point_base)
(setq list_ent (ss-enlst ss))
(setq tp (dxf1 (entget (nth 0 list_ent)) 0))
(cond
((member tp '("REGION" "LWPOLYLINE" "LINE" "CIRCLE" "ARC"))
(setq list_bl (mapcar '(lambda (x) (vla-get-LinetypeScale (en2obj x))) list_ent))
)
((= tp "HATCH")
(setq list_bl (mapcar '(lambda (x) (vla-get-PatternScale (en2obj x))) list_ent))
)
((= tp "INSERT")
(setq list_bl
(list
(mapcar '(lambda (x) (vla-get-xscalefactor (en2obj x))) list_ent)
(mapcar '(lambda (x) (vla-get-yscalefactor (en2obj x))) list_ent)
(mapcar '(lambda (x) (vla-get-zscalefactor (en2obj x))) list_ent)
)
)
)
((member tp '("HATCH" "INSERT"))
(setq list_bl (mapcar '(lambda (x) (vla-get-Height (en2obj x))) list_ent))
)
((wcmatch tp "*DIMENSION")
;(vla-put-ScaleFactor obj bl)
(setq list_bl (mapcar '(lambda (x) (vla-get-ScaleFactor (en2obj x))) list_ent))
)
)
(setq flag_dynamic nil);;默认启用动态比例
(setq flag_secondClick nil) ;第二次鼠标左键，结束程序
(setq bl 1)
(setq flag_circulate T)
(while flag_circulate
(setq mouse (grread T 12 0))
(setq a (car mouse) aa (cadr mouse))
(cond
;按键q或者Q字高增加一倍
((and (= 2 a) (or (= 100 aa) (= 68 aa)));2表示键盘输入,'(2 100)表示d键,'(2 68)表示D键
(setq flag_dynamic nil);;关闭动态比例
(setq bl (* bl 2))
(bl_update_time_batch list_ent list_bl bl)
(text_update (rtos bl));;更新文字
)
;按键w或者W字高缩小一倍
((and (= 2 a) (or (= 120 aa) (= 88 aa)));2表示键盘输入,'(2 120)表示x键,'(2 88)表示X键
(setq flag_dynamic nil);;关闭动态比例
(setq bl (/ bl 2))
;(if(= tp "INSERT")(if (< 0 (1- bl))(setq bl (1- bl)))(setq bl (/ bl 2)));;块单独区分,加减更适用
;(if (< bL 0.01)(setq bL 0.01));;防止比例为太杂****************************************
(bl_update_time_batch list_ent list_bl bl)
(text_update (rtos bl));;更新文字
)
;按键e或者E指定比例
((and (= 2 a) (or (= 101 aa) (= 69 aa)))
(setq flag_dynamic nil);;关闭动态比例
(setq bl (getreal "\n 指定缩放比例:"))
(bl_update_time_batch list_ent list_bl bl)
(text_update (rtos bl));;更新文字
)
((and(= a 5) flag_dynamic);鼠标移动和启用动态比例
(redraw)
(grdraw point_base aa 1);画向量
(setq bl (distance point_base aa))
(cond
((and (< 0 bl) (< bl 0.1))
(setq bl (* (fix (/ bl 0.01)) 0.01) color 1);规范0~1之间取值,模数=0.1
)
((and (<= 0.1 bl) (< bl 1))
(setq bl (* (fix (/ bl 0.1)) 0.1) color 2);规范0~1之间取值,模数=0.1
)
((and (<= 1 bl) (< bl 10))
(setq bl (* (fix (/ bl 0.5)) 0.5) color 3);规范1~10之间取值,模数=0.5
)
((and (<= 10 bl) (< bl 20))
(setq bl (fix bl) color 4);规范10~20之间取值,模数=1
)
((and (<= 20 bl) (< bl 100))
(setq bl (* (fix (/ bl 5)) 5) color 4);规范20~100之间取值,模数=5
)
((<= 100 bl)
(setq bl (* (fix (/ bl 10)) 10) color 6);规范20~100之间取值,模数=10
)
((= 0 bl) (setq bl 1 color 6))
)
(bl_update_time_batch list_ent list_bl bl);;更新比例
(text_update (rtos bl));;更新文字
)
((and (= a 5) (not flag_dynamic));鼠标移动,不启用动态比例
(text_update (strcat "当前变化倍数：" (rtos bl 2 2) "\n【放大(D)/缩小(X)/指定(E)/动态(左键)/退出(空格)】"));;更新文字
)
((= a 3);鼠标左键,启用动态比例
(setq flag_dynamic T)
(setq point_base aa)
(if (= flag_secondClick nil);识别第二次点击鼠标左键
(setq flag_secondClick T)
(setq flag_circulate nil)
)
)
((or
(= 25 a) (= 11 a) ;右键
(and (= a 2) (= aa 13));回车
(and (= a 2) (= aa 32));或空格
)
(setq flag_circulate nil)
)
)
)
(redraw)
(if text (entdel text));删除临时文字
(princ)
)
;;!!!!!!!!!!!主程序------------------
(princ (slmsg "\n 选择修改比例的实体" "\n 選擇修改比例的實體"))
(setq ss (ssget ":S"))
(cond
((= (sslength ss) 1)
(setq nam (ssname ss 0))
(main_process nam (e-mid nam))
)
((> (sslength ss) 1)
(if
(or
(boolean_typeOfSs ss "*DIMENSION")
(boolean_typeOfSs ss "TEXT")
(boolean_typeOfSs ss "MTEXT")
(boolean_typeOfSs ss "REGION")
(boolean_typeOfSs ss "LWPOLYLINE")
(boolean_typeOfSs ss "LINE")
(boolean_typeOfSs ss "CIRCLE")
(boolean_typeOfSs ss "ARC")
(boolean_typeOfSs ss "HATCH")
(boolean_typeOfSs ss "INSERT")
)
(main_process_batch ss '(0 0 0))
(main_process (ssname ss 0) '(0 0 0))
)
)
)
)
选择集处理部分，测试不成功，还有，实体类型支持过少点，剩余不支持类型可以整合
[*](command "scale" ss "" "non" pt0 pause)思路处理如何？
额。。。。。。。。。。
(setq list_ent (pickset_2list ss))缺函数 pickset_2list
;选择集与对象名表互转
(defun pickset_2list (ss / enlst)
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
)
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss))
)
)
) 本帖最后由 andyzha 于 2022-5-8 11:54 编辑
20060510412 发表于 2022-5-7 20:24
在源代码中搜索这个文本所在的行，把那一行注释掉就行了
我已经删掉了，但是选择对象后还会间断一下，不是马上就进入缩放状态，如何修改中间的停顿呢？应该是为了显示这段临时文字做的停顿。
个人觉得第一个临时文字有些赘余，显示缩放比例的临时文字应该保留，本来这个程序就是为了集多种对象缩放为一个命令的超级调整，应该保持简洁高效的风格，一针见血，直达操作的目的本源，期待你的后期优化。
谢谢，挺好用的，我CAD调整图案填充的时候不动态显示 很好，谢谢！ 已下载 用用看 很不錯，謝謝你的分享！ 謝謝分享！ 本帖最后由 ynhh 于 2022-5-1 17:21 编辑
单行文字也只能处理一个
不能如你动画中的可框选啊
不能多选就意义不大了
你说的第3条无法做到，请你再看看
本帖最后由 20060510412 于 2022-5-1 17:28 编辑
ynhh 发表于 2022-5-1 17:18
单行文字也只能处理一个
不能如你动画中的可框选啊
不能多选就意义不大了
批量处理，需要先选择，再执行命令。
主要是考虑到选择同类型的图元，手工不容易做到。
将选择动作放在执行命令之前，也可以方便使用小菜选择易之类的插件，进行批量选取。
66666666666666666