一键将所有选择内容更改为251号颜色，含所有块、块内文字、尺寸标志及所有尺寸内容

小毛草

一键将所有选择内容更改为251号颜色，含所有块、块内文字、尺寸标志及所有尺寸内容

2. ;; ;; 一键改变所有选择内容为251号色。
   
3. (defun c:ts (/ ss doc blks)
   
4.   (vl-load-com) ; 加载 ActiveX 支持
   
5.   (setvar "cmdecho" 0) ; 关闭命令回显
   
6. 
   
7.   ;; 解锁所有图层
   
8.   (command "layer" "u" "*" "s" "0" "")
   
9. 
   
10.   ;; 获取当前文档和块集合
    
11.   (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
    
12.   (setq blks (vla-get-blocks doc))
    
13. 
    
14.   ;; 遍历所有块并修改块名为 _archtick 的块颜色
    
15.   (vlax-for blk blks
    
16.     (if (= (vla-get-name blk) "_archtick")
    
17.       (vlax-for obj blk
    
18.         (vla-put-color obj 251) ; 修改块内对象颜色
    
19.       )
    
20.     )
    
21.   )
    
22. 
    
23.   ;; 选择对象
    
24.   (setq ss (ssget)) ; 选择对象
    
25. 
    
26.   ;; 如果选择集不为空
    
27.   (if ss
    
28.     (progn
    
29.       ;; 遍历选择集并修改颜色
    
30.       (vlax-for obj (vla-get-ActiveSelectionSet doc)
    
31.         (ChColor obj) ; 调用递归函数修改颜色
    
32.       )
    
33.       ;; 清除选择集
    
34.       (vla-delete (vla-get-ActiveSelectionSet doc))
    
35.       (princ "\n所有选择对象颜色已修改为 251 号色。")
    
36.     )
    
37.     (princ "\n未选择到任何对象。")
    
38.   )
    
39.   (princ)
    
40. )
    
41. 
    
42. ;; 递归函数：修改对象及其子对象的颜色
    
43. (defun ChColor (obj / blkName)
    
44.   ;; 修改当前对象的颜色
    
45.   (vla-put-color obj 251)
    
46. 
    
47.   ;; 如果是块参照，递归处理块内的对象
    
48.   (if (and (= (vla-get-ObjectName obj) "AcDbBlockReference")
    
49.            (setq blkName (vla-get-name obj)))
    
50.     (progn
    
51.       ;; 递归处理块内对象
    
52.       (vlax-for subObj (vla-item blks blkName)
    
53.         (ChColor subObj) ; 递归处理块内对象
    
54.       )
    
55.       ;; 处理块内的属性文字
    
56.       (if (= (vla-get-HasAttributes obj) :vlax-true)
    
57.         (foreach att (vlax-invoke obj 'GetAttributes)
    
58.           (vla-put-color att 251) ; 修改属性文字颜色
    
59.         )
    
60.       )
    
61.     )
    
62.   )
    
63. 
    
64.   ;; 如果是属性文字，修改颜色
    
65.   (if (= (vla-get-ObjectName obj) "AcDbAttributeDefinition")
    
66.     (vla-put-color obj 251)
    
67.   )
    
68. 
    
69.   ;; 如果是多行文字或单行文字，修改颜色
    
70.   (if (wcmatch (vla-get-ObjectName obj) "*Text")
    
71.     (vla-put-color obj 251)
    
72.   )
    
73. 
    
74.   ;; 如果是尺寸标注，修改尺寸线、尺寸文字、尺寸界线等颜色
    
75.   (if (wcmatch (vla-get-ObjectName obj) "*Dimension")
    
76.     (progn
    
77.       (vla-put-DimensionLineColor obj 251) ; 尺寸线颜色
    
78.       (vla-put-ExtensionLineColor obj 251) ; 尺寸界线颜色
    
79.       (vla-put-TextColor obj 251) ; 尺寸文字颜色
    
80.     )
    
81.   )
    
82. )

;; ;; 一键改变所有选择内容为251号色。<br /> (defun c:ts (/ ss doc blks)<br />   (vl-load-com) ; 加载 ActiveX 支持<br />   (setvar "cmdecho" 0) ; 关闭命令回显<br /> <br />   ;; 解锁所有图层<br />   (command "layer" "u" "*" "s" "0" "")<br /> <br />   ;; 获取当前文档和块集合<br />   (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))<br />   (setq blks (vla-get-blocks doc))<br /> <br />   ;; 遍历所有块并修改块名为 _archtick 的块颜色<br />   (vlax-for blk blks<br />     (if (= (vla-get-name blk) "_archtick")<br />       (vlax-for obj blk<br />         (vla-put-color obj 251) ; 修改块内对象颜色<br />       )<br />     )<br />   )<br /> <br />   ;; 选择对象<br />   (setq ss (ssget)) ; 选择对象<br /> <br />   ;; 如果选择集不为空<br />   (if ss<br />     (progn<br />       ;; 遍历选择集并修改颜色<br />       (vlax-for obj (vla-get-ActiveSelectionSet doc)<br />         (ChColor obj) ; 调用递归函数修改颜色<br />       )<br />       ;; 清除选择集<br />       (vla-delete (vla-get-ActiveSelectionSet doc))<br />       (princ "\n所有选择对象颜色已修改为 251 号色。")<br />     )<br />     (princ "\n未选择到任何对象。")<br />   )<br />   (princ)<br /> )<br /> <br /> ;; 递归函数：修改对象及其子对象的颜色<br /> (defun ChColor (obj / blkName)<br />   ;; 修改当前对象的颜色<br />   (vla-put-color obj 251)<br /> <br />   ;; 如果是块参照，递归处理块内的对象<br />   (if (and (= (vla-get-ObjectName obj) "AcDbBlockReference")<br />            (setq blkName (vla-get-name obj)))<br />     (progn<br />       ;; 递归处理块内对象<br />       (vlax-for subObj (vla-item blks blkName)<br />         (ChColor subObj) ; 递归处理块内对象<br />       )<br />       ;; 处理块内的属性文字<br />       (if (= (vla-get-HasAttributes obj) :vlax-true)<br />         (foreach att (vlax-invoke obj 'GetAttributes)<br />           (vla-put-color att 251) ; 修改属性文字颜色<br />         )<br />       )<br />     )<br />   )<br /> <br />   ;; 如果是属性文字，修改颜色<br />   (if (= (vla-get-ObjectName obj) "AcDbAttributeDefinition")<br />     (vla-put-color obj 251)<br />   )<br /> <br />   ;; 如果是多行文字或单行文字，修改颜色<br />   (if (wcmatch (vla-get-ObjectName obj) "*Text")<br />     (vla-put-color obj 251)<br />   )<br /> <br />   ;; 如果是尺寸标注，修改尺寸线、尺寸文字、尺寸界线等颜色<br />   (if (wcmatch (vla-get-ObjectName obj) "*Dimension")<br />     (progn<br />       (vla-put-DimensionLineColor obj 251) ; 尺寸线颜色<br />       (vla-put-ExtensionLineColor obj 251) ; 尺寸界线颜色<br />       (vla-put-TextColor obj 251) ; 尺寸文字颜色<br />     )<br />   )<br /> )

mequan

试用了一下，发现不能框选多个进行修改，只能点选

小毛草

应该可以框选的，我这边用2016是可以框选多个进行选择的,还可以用下面这个一键恢复原有颜色！可以试一下！

2. (defun c:s11 (/ ss doc blks)
   
3.   (vl-load-com) ; 加载 ActiveX 支持
   
4.   (setvar "cmdecho" 0) ; 关闭命令回显
   
5. 
   
6.   ;; 获取当前文档和块集合
   
7.   (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
   
8.         blks (vla-get-blocks doc))
   
9. 
   
10.   ;; 提示用户选择对象
    
11.   (princ "选择对象颜色随层: ")
    
12.   (setq ss (ssget)) ; 选择对象
    
13. 
    
14.   ;; 如果选择集不为空
    
15.   (if ss
    
16.     (progn
    
17.       ;; 遍历选择集并修改颜色为随层
    
18.       (vlax-for obj (vla-get-ActiveSelectionSet doc)
    
19.         (ChColorToByLayer obj) ; 调用递归函数修改颜色
    
20.       )
    
21.       ;; 清除选择集
    
22.       (vla-delete (vla-get-ActiveSelectionSet doc))
    
23.       (princ "\n所有选择对象颜色已修改为随层。")
    
24.     )
    
25.     (princ "\n未选择到任何对象。")
    
26.   )
    
27.   (setvar "cmdecho" 1)
    
28.   (princ)
    
29. )
    
30. 
    
31. ;; 递归函数：修改对象及其子对象的颜色为随层
    
32. (defun ChColorToByLayer (obj / blkName)
    
33.   ;; 修改当前对象的颜色为随层
    
34.   (vla-put-Color obj 256) ; 256 是 ByLayer 的颜色索引
    
35. 
    
36.   ;; 如果是块参照，递归处理块内的对象
    
37.   (if (and (= (vla-get-ObjectName obj) "AcDbBlockReference")
    
38.            (setq blkName (vla-get-name obj)))
    
39.     (progn
    
40.       ;; 递归处理块内对象
    
41.       (vlax-for subObj (vla-item blks blkName)
    
42.         (ChColorToByLayer subObj) ; 递归处理块内对象
    
43.       )
    
44.       ;; 处理块内的属性文字
    
45.       (if (= (vla-get-HasAttributes obj) :vlax-true)
    
46.         (foreach att (vlax-invoke obj 'GetAttributes)
    
47.           (vla-put-Color att 256) ; 修改属性文字颜色为随层
    
48.         )
    
49.       )
    
50.     )
    
51.   )
    
52. 
    
53.   ;; 如果是属性文字，修改颜色为随层
    
54.   (if (= (vla-get-ObjectName obj) "AcDbAttributeDefinition")
    
55.     (vla-put-Color obj 256)
    
56.   )
    
57. 
    
58.   ;; 如果是多行文字或单行文字，修改颜色为随层
    
59.   (if (wcmatch (vla-get-ObjectName obj) "*Text")
    
60.     (vla-put-Color obj 256)
    
61.   )
    
62. 
    
63.   ;; 如果是尺寸标注，修改尺寸线、尺寸文字、尺寸界线等颜色为随层
    
64.   (if (wcmatch (vla-get-ObjectName obj) "*Dimension")
    
65.     (progn
    
66.       (vla-put-DimensionLineColor obj 256) ; 尺寸线颜色为随层
    
67.       (vla-put-ExtensionLineColor obj 256) ; 尺寸界线颜色为随层
    
68.       (vla-put-TextColor obj 4) ; 尺寸文字颜色为随层
    
69.     )
    
70.   )
    
71. )
    
72. ;;;改对象颜色为以图层颜色为线形颜色
    

(defun c:s11 (/ ss doc blks)<br />   (vl-load-com) ; 加载 ActiveX 支持<br />   (setvar "cmdecho" 0) ; 关闭命令回显<br /> <br />   ;; 获取当前文档和块集合<br />   (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))<br />         blks (vla-get-blocks doc))<br /> <br />   ;; 提示用户选择对象<br />   (princ "选择对象颜色随层: ")<br />   (setq ss (ssget)) ; 选择对象<br /> <br />   ;; 如果选择集不为空<br />   (if ss<br />     (progn<br />       ;; 遍历选择集并修改颜色为随层<br />       (vlax-for obj (vla-get-ActiveSelectionSet doc)<br />         (ChColorToByLayer obj) ; 调用递归函数修改颜色<br />       )<br />       ;; 清除选择集<br />       (vla-delete (vla-get-ActiveSelectionSet doc))<br />       (princ "\n所有选择对象颜色已修改为随层。")<br />     )<br />     (princ "\n未选择到任何对象。")<br />   )<br />   (setvar "cmdecho" 1)<br />   (princ)<br /> )<br /> <br /> ;; 递归函数：修改对象及其子对象的颜色为随层<br /> (defun ChColorToByLayer (obj / blkName)<br />   ;; 修改当前对象的颜色为随层<br />   (vla-put-Color obj 256) ; 256 是 ByLayer 的颜色索引<br /> <br />   ;; 如果是块参照，递归处理块内的对象<br />   (if (and (= (vla-get-ObjectName obj) "AcDbBlockReference")<br />            (setq blkName (vla-get-name obj)))<br />     (progn<br />       ;; 递归处理块内对象<br />       (vlax-for subObj (vla-item blks blkName)<br />         (ChColorToByLayer subObj) ; 递归处理块内对象<br />       )<br />       ;; 处理块内的属性文字<br />       (if (= (vla-get-HasAttributes obj) :vlax-true)<br />         (foreach att (vlax-invoke obj 'GetAttributes)<br />           (vla-put-Color att 256) ; 修改属性文字颜色为随层<br />         )<br />       )<br />     )<br />   )<br /> <br />   ;; 如果是属性文字，修改颜色为随层<br />   (if (= (vla-get-ObjectName obj) "AcDbAttributeDefinition")<br />     (vla-put-Color obj 256)<br />   )<br /> <br />   ;; 如果是多行文字或单行文字，修改颜色为随层<br />   (if (wcmatch (vla-get-ObjectName obj) "*Text")<br />     (vla-put-Color obj 256)<br />   )<br /> <br />   ;; 如果是尺寸标注，修改尺寸线、尺寸文字、尺寸界线等颜色为随层<br />   (if (wcmatch (vla-get-ObjectName obj) "*Dimension")<br />     (progn<br />       (vla-put-DimensionLineColor obj 256) ; 尺寸线颜色为随层<br />       (vla-put-ExtensionLineColor obj 256) ; 尺寸界线颜色为随层<br />       (vla-put-TextColor obj 4) ; 尺寸文字颜色为随层<br />     )<br />   )<br /> )<br /> ;;;改对象颜色为以图层颜色为线形颜色<br />

qazxswk

试试修改多重引线。

sky899150

对天正的那个标高图元不起作用

小毛草

不一定支持天正文件格式，我这边不用天正！

惜惜2

块中块不支持啊，属性赋值也不行

小毛草

惜惜2 发表于 2025-1-17 15:38
块中块不支持啊，属性赋值也不行

应该可以吧，我试了2016是可以的！

惜惜2

小毛草 发表于 2025-1-17 16:13
应该可以吧，我试了2016是可以的！

属性的值不行

cghdy

同名块也会被修改颜色，建议遍历块时将要修改的块改下名再改颜色