（XD:Block:Delete）删除指定文档的块（处理锁定层）

marting

1. (defun XD:Block:Delete (doc lst / blc bln lck rtn)
   
2.   (if (not doc)
   
3.     (setq doc (vla-get-activedocument (vlax-get-acad-object)))
   
4.   )
   
5.   (setq blc (vla-get-blocks doc)
   
6.         lst (mapcar 'strcase lst)
   
7.   )
   
8.   (vlax-for lay (vla-get-layers doc)
   
9.     (if (= :vlax-true (vla-get-lock lay))
   
10.       (progn (setq lck (cons lay lck))
    
11.              (vla-put-lock lay :vlax-false)
    
12.       )
    
13.     )
    
14.   )
    
15.   (vlax-for def blc
    
16.     (vlax-for obj def
    
17.       (if (and (= "AcDbBlockReference" (vla-get-objectname obj))
    
18.                (or (and (vlax-property-available-p obj 'effectivename)
    
19.                         (setq bln (strcase (vla-get-effectivename obj)))
    
20.                    )
    
21.                    (setq bln (strcase (vla-get-name obj)))
    
22.                )
    
23.                (vl-some '(lambda (x) (wcmatch bln x)) lst)
    
24.           )
    
25.         (progn (vl-catch-all-apply 'vla-delete (list obj))
    
26.                (or (member bln rtn) (setq rtn (cons bln rtn)))
    
27.         )
    
28.       )
    
29.     )
    
30.   )
    
31.   (foreach lay lck (vla-put-lock lay :vlax-true))
    
32.   (vl-remove-if
    
33.     '(lambda (x)
    
34.        (vl-catch-all-error-p
    
35.          (vl-catch-all-apply 'vla-delete (list (vla-item blc x)))
    
36.        )
    
37.      )
    
38.     rtn
    
39.   )
    
40. )
    

(defun XD:Block:Delete (doc lst / blc bln lck rtn)<br />   (if (not doc)<br />     (setq doc (vla-get-activedocument (vlax-get-acad-object)))<br />   )<br />   (setq blc (vla-get-blocks doc)<br />         lst (mapcar 'strcase lst)<br />   )<br />   (vlax-for lay (vla-get-layers doc)<br />     (if (= :vlax-true (vla-get-lock lay))<br />       (progn (setq lck (cons lay lck))<br />              (vla-put-lock lay :vlax-false)<br />       )<br />     )<br />   )<br />   (vlax-for def blc<br />     (vlax-for obj def<br />       (if (and (= "AcDbBlockReference" (vla-get-objectname obj))<br />                (or (and (vlax-property-available-p obj 'effectivename)<br />                         (setq bln (strcase (vla-get-effectivename obj)))<br />                    )<br />                    (setq bln (strcase (vla-get-name obj)))<br />                )<br />                (vl-some '(lambda (x) (wcmatch bln x)) lst)<br />           )<br />         (progn (vl-catch-all-apply 'vla-delete (list obj))<br />                (or (member bln rtn) (setq rtn (cons bln rtn)))<br />         )<br />       )<br />     )<br />   )<br />   (foreach lay lck (vla-put-lock lay :vlax-true))<br />   (vl-remove-if<br />     '(lambda (x)<br />        (vl-catch-all-error-p<br />          (vl-catch-all-apply 'vla-delete (list (vla-item blc x)))<br />        )<br />      )<br />     rtn<br />   )<br /> )<br />

csy0415

大师请问这个只在在DBX里面调用有没有问题？