[转贴]：Purge

eachy · 发表于 2004-1-27 18:44:16

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

转自： http://www.jtbworld.com/?/lisp/purger.htm
放到这里找起来方便：）

;;; PURGER.LSP
;;;
;;; Various purge functions with no command line echo
;;;
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2003 JTB World, All Rights Reserved
;;; Website: [url]www.jtbworld.com[/url] / [url]http://jtbworld.vze.com[/url]
;;; E-mail: [email]info@jtbworld.com[/email] / [email]jtbworld@hotmail.com[/email]
;;; 2000-02-12 - First release
;;; 2003-01-09 - More added
;;; Written for AutoCAD 2000, 2000i and 2002
;;;
;;; Purge named block
;;; Example: (ax:purge-block (vla-get-activedocument (vlax-get-acad-object)) "testblock")
;;; Argument: doc {document}
;;; name {a block name}
;;; Return values: T if successful, nil if not successful
(defun ax:purge-block (doc name)
(if (vl-catch-all-error-p
(vl-catch-all-apply
'vla-delete
(list (vl-catch-all-apply
'vla-item
(list (vla-get-blocks doc) name)
)
)
)
)
nil ; name cannot be purged or doesn't exist
T ; name purged
)
)
;;; Purge named layer
;;; Example: (ax:purge-layer (vla-get-activedocument (vlax-get-acad-object)) "testlayer")
;;; Argument: doc {document}
;;; name {a layer name}
;;; Return values: T if successful, nil if not successful
(defun ax:purge-layer (doc name)
(if (vl-catch-all-error-p
(vl-catch-all-apply
'vla-delete
(list (vl-catch-all-apply
'vla-item
(list (vla-get-layers doc) name)
)
)
)
)
nil ; name cannot be purged or doesn't exist
T ; name purged
)
)
;;; Purge all layers
;;; Example: (ax:purge-all-layers (vla-get-activedocument (vlax-get-acad-object)))
;;; Argument: doc {document}
(defun ax:purge-all-layers (doc)
(vlax-for item (vla-get-layers doc)
(purge-layer (vla-get-name item))
)
)
;;; Purge all layers except those in list
;;; Example: (ax:purge-layers (vla-get-activedocument (vlax-get-acad-object)) '("DIM" "LAYER1"))
;;; Argument: doc {document}
;;; name {a layer name list}
(defun ax:purge-layers (doc except)
(vlax-for item (vla-get-layers doc)
(setq ln (vla-get-name item))
(if (not (member (strcase ln) except))
(purge-layer ln)
)
)
)
;;; Purge all with no echo to command window
;;; Example: (ax:purge-no-echo (vla-get-activedocument (vlax-get-acad-object)))
;;; Argument: doc {document}
(defun ax:purge-no-echo (doc)
;;; Returns a list of keynames from the specified dictionary
(defun getkeys (dictName / tmp)
(if (setq tmp (dictsearch (namedobjdict) dictName))
(massoc 3 tmp)
)
)
;;; Retrieves the entity name of the specified dictionary
(defun getdictname (dictName)
(if (setq tmp (dictsearch (namedobjdict) dictName))
(cdr (assoc -1 tmp))
)
)
;;; Utility function to get multiple group code CDRs
(defun massoc (key alist / x nlist)
(foreach x alist
(if (eq key (car x))
(setq nlist (cons (cdr x) nlist))
)
)
(reverse nlist)
)
(vlax-for item (vla-get-blocks doc)
(vl-catch-all-apply 'vla-delete (list item))
)
(vlax-for item (vla-get-dimstyles doc)
(vl-catch-all-apply 'vla-delete (list item))
)
(vlax-for item (vla-get-linetypes doc)
(vl-catch-all-apply 'vla-delete (list item))
)
(vlax-for item (vla-get-plotconfigurations doc)
(vl-catch-all-apply 'vla-delete (list item))
)
; textstyles
(vlax-for item (vla-get-textstyles doc)
(if (= (cdr (assoc 70 (entget (vlax-vla-object->ename item)))) 0)
(vl-catch-all-apply 'vla-delete (list item))
)
)
; shapes
(vlax-for item (vla-get-textstyles doc)
(if (= (cdr (assoc 70 (entget (vlax-vla-object->ename item)))) 1)
(vl-catch-all-apply 'vla-delete (list item))
)
)
(setq li (getkeys "ACAD_MLINESTYLE"))
(setq len (length li))
; one style has to be left
(foreach na (cdr li)
(delrecord "ACAD_MLINESTYLE" na)
)
(setq li (getkeys "ACAD_MLINESTYLE"))
(setq len (length li))
(if (> len 1)
(delrecord "ACAD_MLINESTYLE" (car li))
)
(vlax-for item (vla-get-layers doc)
(vl-catch-all-apply 'vla-delete 'item)
)
nil
)
;;; Purge/delete all layer filter or filters
;;; Example: (DeleteLayerFilters)
(defun DeleteLayerFilters ()
(vl-Catch-All-Apply
'(lambda ()
(vla-Remove
(vla-GetExtensionDictionary
(vla-Get-Layers
(vla-Get-ActiveDocument (vlax-Get-Acad-Object))
)
)
"ACAD_LAYERFILTERS"
)
)
)
(princ)
)
;;; Purge/delete all layer states
;;; Example: (DeleteLayerStates)
(defun DeleteLayerStates ()
(vl-Catch-All-Apply
'(lambda ()
(vla-Remove (vla-GetExtensionDictionary
(vla-Get-Layers
(vla-Get-ActiveDocument
(vlax-Get-Acad-Object))))
"ACAD_LAYERSTATES")))
(princ)
)
;;; Purge/delete all Express Tool layer states
;;; Example: (LmanKill)
(defun LmanKill (/ lyr ent cnt)
(setq cnt 0)
(while (setq lyr (tblnext "layer" (not lyr)))
(setq ent (entget (tblobjname "layer" (cdr (assoc 2 lyr)))'("RAK")))
(if (and ent (assoc -3 ent))
(progn
(setq ent (subst '(-3 ("RAK")) (assoc -3 ent) ent))
(entmod ent)
(setq cnt (1+ cnt))
)
)
)
(princ)
)
;;; (deleteAllPageSetups)
(defun deleteAllPageSetups (/ pc)
(vlax-for pc (vla-get-plotconfigurations (vla-get-activedocument (vlax-get-acad-object)))
(vla-delete pc)
)
)
(defun PurgeAnonymGroups (/ grpList index grp)
(setq grpList (dictsearch (namedobjdict) "ACAD_GROUP"))
(setq index 1)
(while (setq grp (nth index grplist))
(if (= (car grp) 3)
(progn
(if (= (chr 42) (substr (cdr grp) 1 1))
(entdel (cdr (nth (+ index 1) grplist)))
)
)
)
(setq index (+ 1 index))
)
(princ)
)
(defun PurgeAllGroups (/ grpList index grp)
(setq grpList (dictsearch (namedobjdict) "ACAD_GROUP"))
(setq index 1)
(while (setq grp (nth index grplist))
(if (= (car grp) 3)
(entdel (cdr (nth (+ index 1) grplist)))
)
(setq index (+ 1 index))
)
(princ)
)
(defun DelACAD_VBA ()
(dictremove (namedobjdict) "ACAD_VBA")
(princ)
)
(defun PurgeAPPID (/ appid)
(vl-load-com)
(vlax-for appid (vla-get-registeredapplications
(vla-get-activedocument
(vlax-get-acad-object)
)
)
(vl-catch-all-apply 'vla-delete (list appid))
)
(princ)
)
(princ)

;;; PURGER.LSP 
;;; 
;;; Various purge functions with no command line echo 
;;; 
;;; By Jimmy Bergmark 
;;; Copyright (C) 1997-2003 JTB World, All Rights Reserved 
;;; Website: [url]www.jtbworld.com[/url] / [url]http://jtbworld.vze.com[/url] 
;;; E-mail: [email]info@jtbworld.com[/email] / [email]jtbworld@hotmail.com[/email] 
;;; 2000-02-12 - First release 
;;; 2003-01-09 - More added 
;;; Written for AutoCAD 2000, 2000i and 2002 
;;; 
 
;;; Purge named block 
;;; Example: (ax:purge-block (vla-get-activedocument (vlax-get-acad-object)) "testblock") 
;;; Argument: doc {document} 
;;;           name {a block name} 
;;; Return values: T if successful, nil if not successful 
(defun ax:purge-block (doc name) 
  (if (vl-catch-all-error-p 
        (vl-catch-all-apply 
          'vla-delete 
          (list (vl-catch-all-apply 
                  'vla-item 
                  (list (vla-get-blocks doc) name) 
                ) 
          ) 
        ) 
      ) 
    nil ; name cannot be purged or doesn't exist 
    T ; name purged 
  ) 
) 
 
;;; Purge named layer 
;;; Example: (ax:purge-layer (vla-get-activedocument (vlax-get-acad-object)) "testlayer") 
;;; Argument: doc {document} 
;;;           name {a layer name} 
;;; Return values: T if successful, nil if not successful 
(defun ax:purge-layer (doc name) 
  (if (vl-catch-all-error-p 
        (vl-catch-all-apply 
          'vla-delete 
          (list (vl-catch-all-apply 
                  'vla-item 
                  (list (vla-get-layers doc) name) 
                ) 
          ) 
        ) 
      ) 
    nil ; name cannot be purged or doesn't exist 
    T ; name purged 
  ) 
) 
 
;;; Purge all layers 
;;; Example: (ax:purge-all-layers (vla-get-activedocument (vlax-get-acad-object))) 
;;; Argument: doc {document} 
(defun ax:purge-all-layers (doc) 
  (vlax-for item (vla-get-layers doc) 
    (purge-layer (vla-get-name item)) 
  ) 
) 
 
;;; Purge all layers except those in list 
;;; Example: (ax:purge-layers (vla-get-activedocument (vlax-get-acad-object)) '("DIM" "LAYER1")) 
;;; Argument: doc {document} 
;;;           name {a layer name list} 
(defun ax:purge-layers (doc except) 
  (vlax-for item (vla-get-layers doc) 
    (setq ln (vla-get-name item)) 
    (if (not (member (strcase ln) except)) 
      (purge-layer ln) 
    ) 
  ) 
) 
 
;;; Purge all with no echo to command window 
;;; Example: (ax:purge-no-echo (vla-get-activedocument (vlax-get-acad-object))) 
;;; Argument: doc {document} 
(defun ax:purge-no-echo (doc) 
 
;;; Returns a list of keynames from the specified dictionary 
(defun getkeys (dictName / tmp) 
  (if (setq tmp (dictsearch (namedobjdict) dictName)) 
    (massoc 3 tmp) 
  ) 
) 
 
;;; Retrieves the entity name of the specified dictionary 
(defun getdictname (dictName) 
  (if (setq tmp (dictsearch (namedobjdict) dictName)) 
    (cdr (assoc -1 tmp)) 
  ) 
) 
   
;;; Utility function to get multiple group code CDRs 
(defun massoc (key alist / x nlist) 
  (foreach x alist 
    (if (eq key (car x)) 
      (setq nlist (cons (cdr x) nlist)) 
    ) 
  ) 
  (reverse nlist) 
) 
   
  (vlax-for item (vla-get-blocks doc) 
    (vl-catch-all-apply 'vla-delete (list item)) 
  ) 
  (vlax-for item (vla-get-dimstyles doc) 
    (vl-catch-all-apply 'vla-delete (list item)) 
  ) 
  (vlax-for item (vla-get-linetypes doc) 
    (vl-catch-all-apply 'vla-delete (list item)) 
  ) 
  (vlax-for item (vla-get-plotconfigurations doc) 
    (vl-catch-all-apply 'vla-delete (list item)) 
  ) 
  ; textstyles 
  (vlax-for item (vla-get-textstyles doc) 
    (if (= (cdr (assoc 70 (entget (vlax-vla-object->ename item)))) 0) 
      (vl-catch-all-apply 'vla-delete (list item)) 
    ) 
  ) 
  ; shapes 
  (vlax-for item (vla-get-textstyles doc) 
    (if (= (cdr (assoc 70 (entget (vlax-vla-object->ename item)))) 1) 
      (vl-catch-all-apply 'vla-delete (list item)) 
    ) 
  ) 
  (setq li (getkeys "ACAD_MLINESTYLE")) 
  (setq len (length li)) 
  ; one style has to be left 
  (foreach na (cdr li) 
    (delrecord "ACAD_MLINESTYLE" na) 
  ) 
  (setq li (getkeys "ACAD_MLINESTYLE")) 
  (setq len (length li)) 
  (if (> len 1) 
    (delrecord "ACAD_MLINESTYLE" (car li)) 
  ) 
  (vlax-for item (vla-get-layers doc) 
    (vl-catch-all-apply 'vla-delete 'item) 
  ) 
  nil 
) 
 
;;; Purge/delete all layer filter or filters 
;;; Example: (DeleteLayerFilters) 
(defun DeleteLayerFilters () 
  (vl-Catch-All-Apply 
    '(lambda () 
       (vla-Remove 
         (vla-GetExtensionDictionary 
           (vla-Get-Layers 
             (vla-Get-ActiveDocument (vlax-Get-Acad-Object)) 
           ) 
         ) 
         "ACAD_LAYERFILTERS" 
       ) 
     ) 
  ) 
  (princ) 
) 
 
;;; Purge/delete all layer states 
;;; Example: (DeleteLayerStates) 
(defun DeleteLayerStates  () 
 (vl-Catch-All-Apply 
  '(lambda () 
    (vla-Remove (vla-GetExtensionDictionary 
                 (vla-Get-Layers 
                  (vla-Get-ActiveDocument 
                   (vlax-Get-Acad-Object)))) 
                "ACAD_LAYERSTATES"))) 
 (princ) 
) 
;;; Purge/delete all Express Tool layer states 
;;; Example: (LmanKill) 
(defun LmanKill (/ lyr ent cnt) 
  (setq cnt 0) 
  (while (setq lyr (tblnext "layer" (not lyr))) 
    (setq ent (entget (tblobjname "layer" (cdr (assoc 2 lyr)))'("RAK"))) 
    (if (and ent (assoc -3 ent)) 
      (progn 
        (setq ent (subst '(-3 ("RAK")) (assoc -3 ent) ent)) 
        (entmod ent) 
        (setq cnt (1+ cnt)) 
      ) 
    ) 
  ) 
 (princ) 
) 
;;; (deleteAllPageSetups) 
(defun deleteAllPageSetups (/ pc) 
  (vlax-for pc (vla-get-plotconfigurations (vla-get-activedocument (vlax-get-acad-object))) 
    (vla-delete pc) 
  ) 
) 
(defun PurgeAnonymGroups (/ grpList index grp) 
  (setq grpList (dictsearch (namedobjdict) "ACAD_GROUP")) 
  (setq index 1) 
  (while (setq grp (nth index grplist)) 
    (if        (= (car grp) 3) 
      (progn 
        (if (= (chr 42) (substr (cdr grp) 1 1)) 
          (entdel (cdr (nth (+ index 1) grplist))) 
        ) 
      ) 
    ) 
    (setq index (+ 1 index)) 
  ) 
  (princ) 
) 
(defun PurgeAllGroups (/ grpList index grp) 
  (setq grpList (dictsearch (namedobjdict) "ACAD_GROUP")) 
  (setq index 1) 
  (while (setq grp (nth index grplist)) 
    (if        (= (car grp) 3) 
      (entdel (cdr (nth (+ index 1) grplist))) 
    ) 
    (setq index (+ 1 index)) 
  ) 
  (princ) 
) 
(defun DelACAD_VBA () 
  (dictremove (namedobjdict) "ACAD_VBA") 
  (princ) 
) 
(defun PurgeAPPID (/ appid) 
  (vl-load-com) 
  (vlax-for appid (vla-get-registeredapplications 
                    (vla-get-activedocument 
                      (vlax-get-acad-object) 
                    ) 
                  ) 
    (vl-catch-all-apply 'vla-delete (list appid)) 
  ) 
  (princ) 
) 
(princ)

beijingtuzi · 发表于 2004-2-22 15:17:45

这个lisp的用处是什么？菜鸟一只，没看懂

lsjjm · 发表于 2004-2-23 03:45:12

再推荐一个"Batch Purge 2004":
http://www.afralisp.com/vba/bp2004.htm

n188888888 · 发表于 2004-2-27 11:45:07

对呀,这LISP作用具体是什么,是不是就是CAD里的图形清理命令,如果是那没有什么意义了!!!

海豚 · 发表于 2004-3-6 23:12:25

希望高手们发程序能说明一下。

自由的鱼 · 发表于 2004-3-6 23:22:18

我也希望可以看到简单的说明~

cxzr8 · 发表于 2004-3-17 19:54:53

其实看看说明就知道功能了~~~~
Various purge functions with no command line echo
Purge named block
Purge all layers
Purge all with no echo to command window
Purge/delete all layer states
Purge/delete all Express Tool layer states

账号		自动登录	找回密码
密码			立即注册

[转贴]：Purge

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子