如果有多个，只留下一个块

4o4osan · 发表于 2022-7-5 17:05:54

大家好，

我正在寻找一个例程，它可以在图形中找到一个特定的块，如果有更多具有相同名称的块删除除一个以外的所有。

我在多个图形上运行lisp，根据该图形的“键”更改某些块的属性。因此，关键是块，它应该只在这些图纸中出现一次，否则代码中的所有计算都会出错。
这些键可以位于图形中的任何位置，这意味着它们不在彼此的顶部或具有相同的插入点。

任何想法都将受到高度赞赏。

David Bethel · 发表于 2022-7-5 17:13:51

完全未经测试，可能很危险：

copy


[b][color=BLACK]([/color][/b]defun c:foo [b][color=FUCHSIA]([/color][/b]/ bn b ss en i[b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]while [b][color=NAVY]([/color][/b]not bn[b][color=NAVY])[/color][/b]
   [b][color=NAVY]([/color][/b]setq b [b][color=MAROON]([/color][/b]strcase [b][color=GREEN]([/color][/b]getstring [color=#2f4f4f]"\nBLOCK Name:   "[/color][b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
   [b][color=NAVY]([/color][/b]cond [b][color=MAROON]([/color][/b][b][color=GREEN]([/color][/b]not [b][color=BLUE]([/color][/b]snvalid b[b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b]
         [b][color=MAROON]([/color][/b][b][color=GREEN]([/color][/b]not [b][color=BLUE]([/color][/b]tblsearch [color=#2f4f4f]"BLOCK"[/color] b[b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b]
         [b][color=MAROON]([/color][/b][b][color=GREEN]([/color][/b]setq ss [b][color=BLUE]([/color][/b]ssget [color=#2f4f4f]"X"[/color] [b][color=RED]([/color][/b]list [b][color=PURPLE]([/color][/b]cons 0 [color=#2f4f4f]"INSERT"[/color][b][color=PURPLE])[/color][/b][b][color=PURPLE]([/color][/b]cons 2 b[b][color=PURPLE])[/color][/b][b][color=RED])[/color][/b][b][color=BLUE])[/color][/b][b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b]
         [b][color=MAROON]([/color][/b][b][color=GREEN]([/color][/b]setq bn b[b][color=GREEN])[/color][/b][b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]setq i 0[b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]while [b][color=NAVY]([/color][/b]setq en [b][color=MAROON]([/color][/b]ssname ss i[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
        [b][color=NAVY]([/color][/b]if [b][color=MAROON]([/color][/b]/= i 0[b][color=MAROON])[/color][/b]
             [b][color=MAROON]([/color][/b]entdel en[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b]
        [b][color=NAVY]([/color][/b]setq i [b][color=MAROON]([/color][/b]1+ i[b][color=MAROON])[/color][/b][b][color=NAVY])[/color][/b][b][color=FUCHSIA])[/color][/b]
 [b][color=FUCHSIA]([/color][/b]prin1[b][color=FUCHSIA])[/color][/b][b][color=BLACK])[/color][/b]

而且可能对动态块完全无用。

-大卫

4o4osan · 发表于 2022-7-5 17:17:15

谢谢你的重播David，

我担心此代码将无法在我正在工作的模式下工作。我的代码中的所有处理都是在后台的多个图形上完成的，其中ssget选择是不可能的。

BIGAL · 发表于 2022-7-5 17:26:25

Davids代码将在多个DWG上工作，无需交互，只需采取不同的方法。

C： foo意味着在键盘上键入，因此2个选项（defun foo）将在键盘上或脚本中工作（foo）或（C:foo）

您可以硬编码块名或询问一次，然后将say保存到文本文件中。（setq b

使用脚本将更改多个DWG。我想这就是你现在要做的。如果没有，请解释你是怎么做的。

4o4osan · 发表于 2022-7-5 17:30:33

比加尔，
谢谢你出现在地平线上。

更多的信息可能确实有用。
这是我正在寻找解决方案的代码的一部分。

copy

(setq *acad (vlax-get-acad-object)
docx  (vla-get-activedocument *acad)    
doc (vla-getinterfaceobject *acad (if (< (setq acVer (atoi (getvar "ACADVER"))) 16)
       "ObjectDBX.AxDbDocument" (strcat "ObjectDBX.AxDbDocument." (itoa acVer))))
dwgs files
     dwgs (vl-sort dwgs '<)
)
 
(foreach dwg dwgs;for each dwg of the dwgs list
 (setq dprefix (vl-filename-directory dwg))
 (setq emsg (vl-catch-all-apply '(lambda ()
 (vla-open doc dwg :vlax-false)
      (setq my_doc  (vla-get-activedocument (vlax-get-acad-object)))
                          
(if (= drawing "1")                                  
     (progn 
     (vlax-for layout (vla-get-layouts doc)
     (vlax-for ent (vla-get-block layout)
   (if (and (vlax-property-available-p ent 'hasattributes)
        (eq (vla-get-name ent) bname_dwg))
(progn
  (setq atts (vlax-invoke ent 'getattributes))
                (foreach att atts
                        (if (= (vla-get-tagstring att) tag_dwg)
                                (progn
                                        (setq edit t)
                                        (vla-put-textstring att val_dwg)
                                        (setq key_dwg (vla-get-textstring att))
                                        (setq val_dwg (itoa (+ (atoi val_dwg) _inc) ))
                                )
                        )
                )
)
 
   )
)))
);end if
; here i call another function to change the tag
(if (= TAG_EMPLOYER "1") 
(replace_tags "DWG_" "EMPLOYER#" "B" "Sheet1" key_dwg 1))                            
 ))))

Roy_043 · 发表于 2022-7-5 17:35:53

谢谢Roy_043，

实现您的想法，并在每次绘制完成后将结果设置为零。
它现在工作得很好，当我运行代码时，我只需要少检查一件事。

我喜欢这个论坛：D

4o4osan · 发表于 2022-7-5 17:41:14

我会这样写（基本上就像罗伊那样）：

copy

(vlax-for layout (vla-get-layouts doc)
 (setq found nil)
 (vlax-for ent (vla-get-block layout)
   (if
     (and
       (eq (vla-get-name ent) bname_dwg)
       (vlax-property-available-p ent 'hasattributes) ; Required?
     )
     (if found
       (vla-delete ent) ; Already found one so delete.
       (progn
         (setq found T)
         ... ; Do your stuff.
       )
     )
   )
 )
)

现在我考虑在Documents集合中包含一个使用（getfield）和调用（vla open）的提示符。

Grrr · 发表于 2022-7-5 17:48:00

@Grrr：我认为你的代码没有按预期工作。你测试过了吗？

Roy_043 · 发表于 2022-7-5 17:49:55

@罗伊，这完全没有经过测试，在看了第二眼之后，我不应该包括这一行（我甚至不记得我添加了它-哈哈）：

copy

(defun C:test ( / CADapp Docs BlkNms )
(setq CADapp (vlax-get-acad-object))
(setq Docs (vla-get-Documents CADapp))
(vlax-for doc Docs
        (vlax-for blk (vla-get-Blocks doc)
                (if
                        (and
                                (eq (vla-get-IsLayout blk) :vlax-false)
                                (eq (vla-get-IsDynamicBlock blk) :vlax-false)
                                (eq (vla-get-IsXRef blk) :vlax-false)
                        )
                        (setq BlkNms (cons (vla-get-Name blk) BlkNms))
                )
        ); iterate blkdefs
        (vlax-for layout (vla-get-Layouts doc)
                (vlax-for obj (vla-get-Block layout)
                        (if
                                (and
                                        (= (vla-get-ObjectName obj) "AcDbBlockReference")
                                        (not (vl-remove (vla-get-EffectiveName obj) BlkNms)) ; first block that remove its name from this list is NOT deleted
                                )
                                (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-delete (list obj)))
                                        (progn
                                                (vla-put-Lock (vla-item (vla-get-Layers doc) (vla-get-Layer obj)) :vlax-false)
                                                (vl-catch-all-error-p (vl-catch-all-apply 'vla-delete (list obj)))
                                        ); progn
                                ); if
                        ); if
                ); iterate graphical objects
        ); iterate tabs
); iterate docs                
(princ)
);| defun |; (vl-load-com) (princ)

也许我不得不把它改成：

copy

(eq (vla-get-IsDynamicBlock blk) :vlax-false)

此外，它不符合以下标准：

我不知道你是否指的是其他问题。

Grrr · 发表于 2022-7-5 17:56:21

@Grrr：我看到的主要问题是blkNms列表。

建议：

copy

(eq (vla-get-HasAttributes blk) :vlax-false)

[编程交流] 如果有多个，只留下一个块

发表回复

精选推荐