yaojing38 发表于 2023-3-15 15:50:56

找了很多拆除外部参照的程序,求助帮看看如何只拆除卸载或不存在参照的。

;: https://autocadtips1.com/2011/09/01/autolisp-detach-all-xrefs/ author unknown
; (load "Detachall") Detachall ;
(defun C:Detachall (/ *error* mip:layer-status-restore mip:layer-status-save delete-xref-img-underlay delete-all-dict)

(defun *error* (msg)
(mip:layer-status-restore)
(princ msg)
(princ)
) ;_ end of defun

(defun mip:layer-status-restore ()
(foreach item *PD_LAYER_LST*
    (if (not (vlax-erased-p (car item)))
    (vl-catch-all-apply
      '(lambda ()
      (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
      (vla-put-freeze
      (car item)
      (cdr (assoc "freeze" (cdr item)))
      )
      )
    )
    )
)
(setq *PD_LAYER_LST* nil)
) ;_ end of defun

(defun mip:layer-status-save ()
(setq *PD_LAYER_LST* nil)
(vlax-for item (vla-get-layers(vla-get-activedocument (vlax-get-acad-object)))
    (setq *PD_LAYER_LST*
    (cons
      (list item (cons "freeze" (vla-get-freeze item))(cons "lock" (vla-get-lock item)))
      *PD_LAYER_LST*
    )
    )
    (vla-put-lock item :vlax-false)
    (if (= (vla-get-freeze item) :vlax-true)
    (vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false)))
    )
)
) ;_ end of defun

(defun delete-xref-img-underlay (/ count txt BlkList)
(mip:layer-status-save)

(vlax-for Blk (vla-get-Blocks(vla-get-activedocument (vlax-get-acad-object)))
    (setq BlkList (entget(vlax-vla-object->ename Blk)))
    (vl-catch-all-apply 'eval
      '((setq data2
            (entget
                (cdr
                  (assoc 360
                        (setq data1
                            (entget
                              (vlax-vla-object->ename blk)
                            )
                        )
                  )
                )
            )
      ))
    )
    (if(and
      (= (vla-get-IsXref Blk) :vlax-false)
      (not (wcmatch (vla-get-name Blk) "*|*")
            ;(logand(assoc 70 BlkList)32)
      ;(not(logand(assoc 70 BlkList)32))
    )
         ;(member '(71 . 1) date2)
       )
    (progn
      (setq
      count 0
      txt (strcat " Erase Xref and Underlay in " (vla-get-name Blk))
      )
      (grtext -1 txt)
      (vlax-for Obj Blk
      (setq count (1+ count))
      (if (zerop (rem count 10))(grtext -1 (strcat txt " : " (itoa count))))
      (if
      (and (vlax-write-enabled-p Obj)
      (or
          (and ;_ XREF
          (= (vla-get-ObjectName obj) "AcDbBlockReference")
          (vlax-property-available-p Obj "Path")
          ;(member '(71 . 1) data2)
      ;(logand(assoc 70 BlkList)32)
      (not(logand(assoc 70 BlkList)32))
          ) ;_ end of and
          (and ;_ UNDERLAY
          (wcmatch (vla-get-ObjectName obj) "*Reference")
          (vlax-property-available-p Obj "UnderlayName")
          ) ;_ end of and
          (= (vla-get-ObjectName obj) "AcDbRasterImage") ;_ IMAGE
      ) ;_ end of or
      ) ;_ end of and
      (VL-CATCH-ALL-APPLY 'vla-Delete (list Obj))
      ) ;_ end of if
      ) ;_ end of vlax-for
    ) ;_ end of progn
    ) ;_ end of if
) ;_ end of vlax-for
(mip:layer-status-restore)
) ;_ end of defun

(defun delete-all-dict (dict)
;;; dict - dict name (like "ACAD_IMAGE_DICT", "ACAD_PDFDEFINITIONS" ... )
(vl-catch-all-apply
    '(lambda ()
    (vlax-map-Collection
      (vla-item(vla-get-dictionaries(vla-get-activedocument (vlax-get-acad-object)))dict)
      'vla-delete
    ) ;_ end of vlax-map-Collection
    ) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of defun

(delete-xref-img-underlay)
(command "_-xref" "_d" "*")
(while (> (getvar "CMDACTIVE") 0) (command))
(mapcar 'delete-all-dict (list "ACAD_IMAGE_DICT" "ACAD_PDFDEFINITIONS" "ACAD_DWFDEFINITIONS" "ACAD_DGNDEFINITIONS"))
(command "_.regenall")
(command "_.externalreferences")
(princ)
) ;_ end of defun找了很多拆除外部参照的,或多或少有的会出现错误,,有点拆除清理不彻底,,这个还是比较好的,但是就是是全部拆除,,本人也试了好久研究下,但是确实对面对对象的太生疏,确实没那个能力。只好发出来看有没大佬给看看,怎么加个拆除条件,就是外部参照不存在或者已经卸载就清理外部参照列表。。之前有大哥发过,,还是再发下吧,,感觉挺好的代码,,沉了可惜。。

sniper1111 发表于 2023-3-15 16:04:40

嵌套的参照得逐层拆除。
用到递归

kucha007 发表于 2023-3-15 16:09:08

可以参考一下这个帖子http://bbs.mjtd.com/thread-186503-1-1.html
页: [1]
查看完整版本: 找了很多拆除外部参照的程序,求助帮看看如何只拆除卸载或不存在参照的。