修改一个批量改块内填充类型的工具

Sonnenblumen

恳请各位大师修改一个批量改块内填充图案的工具，将不同块内的同一个填充，改为我需要的填充
以下是G版的代码（感谢Gu_xl版主），但是我不知道如何使用，恳请各位给予帮助，非常感谢！！
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=109395&highlight=%BF%E9

• (defun f (n a b / doc blkdef)
  
•   (if (not
  
•         (VL-CATCH-ALL-ERROR-P
  
•           (setq        blkdef
  
•                  (VL-CATCH-ALL-APPLY
  
•                    'vla-item
  
•                    (list
  
•                      (vla-get-blocks
  
•                        (setq doc
  
•                               (vla-get-ActiveDocument
  
•                                 (vlax-get-acad-object)
  
•                               )
  
•                        )
  
•                      )
  
•                      n
  
•                    )
  
•                  )
  
•           )
  
•         )
  
•       )
  
•     (progn
  
•       (vlax-for        o blkdef
  
•         (if (and
  
•               (= "AcDbHatch" (vla-get-ObjectName o))
  
•               (= (strcase a) (strcase (vla-get-PatternName o)))
  
•             )
  
•           (VL-CATCH-ALL-APPLY
  
•             'vla-SetPattern
  
•             (list o
  
•                   (vla-get-PatternType o)
  
•                   b
  
•             )
  
•           )
  
•         )
  
•       )
  
•       (vla-regen doc :vlax-true)
  
•     )
  
•   )
  
• )
  
  

gaics

Sonnenblumen 发表于 2020-4-13 17:49
非常感谢您，程序很好用，但是有个问题，如果我要改多种图案，就需要在代码里一次次的改填充图案名称，这 ...

1. (defun c:tt (/ ss i ii blk blkname pattern1 pattern2 ly keyword namelist)  (princ "\n >>>>>1-请选择块参照...")
   
2.   (setq ss (ssget '((0 . "INSERT"))))
   
3.   (princ "\n >>>>>2-请选择原填充图案...")
   
4.   (setq pattern1 (cdr (assoc 2 (entget (car (nentselp))))))
   
5.   (princ "\n >>>>>3-请选择新填充图案...")
   
6.   (setq pattern2 (car (nentselp)))
   
7.   (setq ly (cdr (assoc 8 (entget pattern2))))
   
8.   (setq pattern2 (cdr (assoc 2 (entget pattern2))))
   
9.   (initget "1 2")
   
10.   (setq keyword (getkword "\n是否同时更改图层？[<1>改/<2>不改]:"))
    
11.   (setq i 0)
    
12.   (repeat (sslength ss)
    
13.     (setq blk (ssname ss i))
    
14.     (setq blkname (cdr (assoc 2 (entget blk))))
    
15.     (f blkname pattern1 pattern2 keyword ly)
    
16.     (GetBlkNameInBLK blk)
    
17.     (setq namelist (delsame namelist))
    
18.     (setq ii 0)
    
19.     (repeat (length namelist)
    
20.       (setq blkname (nth ii namelist))
    
21.       (f blkname pattern1 pattern2 keyword ly)
    
22.       (setq ii (1+ ii))
    
23.     )
    
24.     (entupd blk);;刷新图元显示
    
25.     (setq i (1+ i))
    
26.   )
    
27.   ;(command "regen")
    
28.   (princ)
    
29. )
    
30. (defun f (n a b c d / doc blkdef)
    
31.   (if (not
    
32.         (VL-CATCH-ALL-ERROR-P
    
33.           (setq        blkdef
    
34.                  (VL-CATCH-ALL-APPLY
    
35.                    'vla-item
    
36.                    (list
    
37.                      (vla-get-blocks
    
38.                        (setq doc
    
39.                               (vla-get-ActiveDocument
    
40.                                 (vlax-get-acad-object)
    
41.                               )
    
42.                        )
    
43.                      )
    
44.                      n
    
45.                    )
    
46.                  )
    
47.           )
    
48.         )
    
49.       )
    
50.     (vlax-for o        blkdef
    
51.       (if (and
    
52.             (= "AcDbHatch" (vla-get-ObjectName o))
    
53.             (= (strcase a) (strcase (vla-get-PatternName o)))
    
54.           )
    
55.         (progn
    
56.           (VL-CATCH-ALL-APPLY
    
57.             'vla-SetPattern
    
58.             (list o
    
59.                   (vla-get-PatternType o)
    
60.                   b
    
61.             )
    
62.           )
    
63.           (if (= c "1")
    
64.             (VL-CATCH-ALL-APPLY 'vla-put-layer (list o d))
    
65.           )
    
66.         )
    
67.       )
    
68.     )
    
69.   )
    
70. )
    
71. (defun GetBlkNameInBLK
    
72.                        (BlkEntName / xBlkName xBlkDef entName1 entType
    
73.                         blkname)
    
74.   (setq xBlkName (cdr (assoc 2 (entget BlkEntName))))
    
75.   (setq xBlkDef (tblobjname "Block" xBlkName))
    
76.   (while (setq entName1 (entnext xBlkDef))
    
77.     (setq entType (cdr (assoc 0 (entget entName1))))
    
78.     (if        (= entType "INSERT")
    
79.       (progn
    
80.         (setq blkname (vla-get-effectivename
    
81.                         (vlax-ename->vla-object entName1)
    
82.                       )
    
83.         )
    
84.         (setq namelist (cons blkname namelist))
    
85.         (GetBlkNameInBLK entName1)
    
86.       )
    
87.     )
    
88.     (setq xBlkDef entName1)
    
89.   )
    
90. )
    
91. (defun delsame (l)
    
92.   (if l
    
93.     (cons (car l)
    
94.           (delsame (vl-remove (car l) (cdr l)))
    
95.     )
    
96.   )
    
97. )

(defun c:tt (/ ss i ii blk blkname pattern1 pattern2 ly keyword namelist)  (princ "\n >>>>>1-请选择块参照...")<br />   (setq ss (ssget '((0 . "INSERT"))))<br />   (princ "\n >>>>>2-请选择原填充图案...")<br />   (setq pattern1 (cdr (assoc 2 (entget (car (nentselp))))))<br />   (princ "\n >>>>>3-请选择新填充图案...")<br />   (setq pattern2 (car (nentselp)))<br />   (setq ly (cdr (assoc 8 (entget pattern2))))<br />   (setq pattern2 (cdr (assoc 2 (entget pattern2))))<br />   (initget "1 2")<br />   (setq keyword (getkword "\n是否同时更改图层？[<1>改/<2>不改]:"))<br />   (setq i 0)<br />   (repeat (sslength ss)<br />     (setq blk (ssname ss i))<br />     (setq blkname (cdr (assoc 2 (entget blk))))<br />     (f blkname pattern1 pattern2 keyword ly)<br />     (GetBlkNameInBLK blk)<br />     (setq namelist (delsame namelist))<br />     (setq ii 0)<br />     (repeat (length namelist)<br />       (setq blkname (nth ii namelist))<br />       (f blkname pattern1 pattern2 keyword ly)<br />       (setq ii (1+ ii))<br />     )<br />     (entupd blk);;刷新图元显示<br />     (setq i (1+ i))<br />   )<br />   ;(command "regen")<br />   (princ)<br /> )<br /> (defun f (n a b c d / doc blkdef)<br />   (if (not<br />         (VL-CATCH-ALL-ERROR-P<br />           (setq        blkdef<br />                  (VL-CATCH-ALL-APPLY<br />                    'vla-item<br />                    (list<br />                      (vla-get-blocks<br />                        (setq doc<br />                               (vla-get-ActiveDocument<br />                                 (vlax-get-acad-object)<br />                               )<br />                        )<br />                      )<br />                      n<br />                    )<br />                  )<br />           )<br />         )<br />       )<br />     (vlax-for o        blkdef<br />       (if (and<br />             (= "AcDbHatch" (vla-get-ObjectName o))<br />             (= (strcase a) (strcase (vla-get-PatternName o)))<br />           )<br />         (progn<br />           (VL-CATCH-ALL-APPLY<br />             'vla-SetPattern<br />             (list o<br />                   (vla-get-PatternType o)<br />                   b<br />             )<br />           )<br />           (if (= c "1")<br />             (VL-CATCH-ALL-APPLY 'vla-put-layer (list o d))<br />           )<br />         )<br />       )<br />     )<br />   )<br /> )<br /> (defun GetBlkNameInBLK<br />                        (BlkEntName / xBlkName xBlkDef entName1 entType<br />                         blkname)<br />   (setq xBlkName (cdr (assoc 2 (entget BlkEntName))))<br />   (setq xBlkDef (tblobjname "Block" xBlkName))<br />   (while (setq entName1 (entnext xBlkDef))<br />     (setq entType (cdr (assoc 0 (entget entName1))))<br />     (if        (= entType "INSERT")<br />       (progn<br />         (setq blkname (vla-get-effectivename<br />                         (vlax-ename->vla-object entName1)<br />                       )<br />         )<br />         (setq namelist (cons blkname namelist))<br />         (GetBlkNameInBLK entName1)<br />       )<br />     )<br />     (setq xBlkDef entName1)<br />   )<br /> )<br /> (defun delsame (l)<br />   (if l<br />     (cons (car l)<br />           (delsame (vl-remove (car l) (cdr l)))<br />     )<br />   )<br /> )

gaics

(f n a b)
(f "块名称" "修改前填充图案名称" "修改后填充图案名称")

(defun c:tt (/ ss i blk pattern1 pattern2)
  (setq ss (ssget '((0 . "INSERT"))))
  (setq pattern1 "ANSI31");;修改前填充图案名称
  (setq pattern2 "ANSI37");;修改后填充图案名称
  (setq i 0)
  (repeat (sslength ss)
    (setq blk(ssname ss i))
    (setq blk(cdr (assoc 2 (entget blk))));;块名称
    (f blk pattern1 pattern2);;调用子程序
    (setq i (1+ i))
  )
  (command "regen")
  (princ)
)
(defun f (n a b / doc blkdef)
  (if (not
        (VL-CATCH-ALL-ERROR-P
          (setq        blkdef
                 (VL-CATCH-ALL-APPLY
                   'vla-item
                   (list
                     (vla-get-blocks
                       (setq doc
                              (vla-get-ActiveDocument
                                (vlax-get-acad-object)
                              )
                       )
                     )
                     n
                   )
                 )
          )
        )
      )
    (progn
      (vlax-for        o blkdef
        (if (and
              (= "AcDbHatch" (vla-get-ObjectName o))
              (= (strcase a) (strcase (vla-get-PatternName o)))
            )
          (VL-CATCH-ALL-APPLY
            'vla-SetPattern
            (list o
                  (vla-get-PatternType o)
                  b
            )
          )
        )
      )
      ;(vla-regen doc :vlax-true);;刷新，建议在主程序中刷新以提高速度
    )
  )
)

1. 
   

复制代码

Sonnenblumen

gaics 发表于 2020-4-13 16:47
(f n a b)
(f "块名称" "修改前填充图案名称" "修改后填充图案名称")

感谢您的回帖，我还是没看明白，能麻烦您帮改一下代码吗？

gaics

Sonnenblumen 发表于 2020-4-13 17:08
感谢您的回帖，我还是没看明白，能麻烦您帮改一下代码吗？

已改。
修改块参照后需要刷新，gu版是在子程序内刷新，批量操作的话影响速度，建议在主程序中刷新。

Sonnenblumen

gaics 发表于 2020-4-13 17:28
已改。
修改块参照后需要刷新，gu版是在子程序内刷新，批量操作的话影响速度，建议在主程序中刷新。

非常感谢您，程序很好用，但是有个问题，如果我要改多种图案，就需要在代码里一次次的改填充图案名称，这样效率会很低，可以实现点选源图案，再点选要替换的图案，再框选要替换的块这样的功能么？

panliang9

以下为搬运，可以全图改。

这个是改具体的。

相关讨论：
https://www.cadtutor.net/forum/topic/63658-change-solid-hatch/

Sonnenblumen

gaics 发表于 2020-4-14 07:50

感谢您的回复，感谢您的代码，非常好用，达到了我的预期，感谢感谢
我还想问您一下，这个是否可以实现，替换的时候给一个选择，被替换的图案是否要跟随源图案图层，这样的功能。您的代码可以替换图案样式，但是不能替换图层，恳请您帮助。

Sonnenblumen

panliang9 发表于 2020-4-14 08:54
以下为搬运，可以全图改。

这个是改具体的。

感谢您的回复，谢谢

Sonnenblumen

gaics 发表于 2020-4-14 07:50

请问大师，如果是嵌套块，这样的替换功能如何实现呢？