Здесь вы можете скачать документацию и программы для САПР AutoCAD, PCAD, 3DS, Inventor, Pro/E, Solidworks и других CAD CAM CAE EDA GIS

Различные функции очистки чертежа от неиспользумеых объектов без эха в командной строке

;;; PURGER.LSP
;;;
;;; Различные функции очистки без эха в командной строке
;;; 
;;; Проверено на AutoCAD 2000, 2000i, 2002, 2004, 2005
;;;

;;; Очистка именнованного блока
;;; Пример: (ax:purge-block (vla-get-activedocument (vlax-get-acad-object)) "testblock")
;;; Аргументы: doc {документ}
;;;           name {имя блока}
;;; возвращаемые значения: T - если успешно, nil - если не успешно
(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 ; имя не может быть очищено или не существует
    T ; имя очищено
  )
)

;;; Очистка именнованного слоя
;;; Пример: (ax:purge-layer (vla-get-activedocument (vlax-get-acad-object)) "testlayer")
;;; Аргументы: doc {документ}
;;;           name {имя слоя}
;;; возвращаемые значения: T - если успешно, nil - если не успешно
(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 ; имя не может быть очищено или не существует
    T ; имя очищено
  )
)

;;; Очистка всех слоев
;;; Пример: (ax:purge-all-layers (vla-get-activedocument (vlax-get-acad-object)))
;;; Аргументы: doc {документ}
(defun ax:purge-all-layers (doc)
  (vlax-for item (vla-get-layers doc)
    (purge-layer (vla-get-name item))
  )
)

;;; Очистка всех слоев кроме указанных в списке
;;; Пример: (ax:purge-layers (vla-get-activedocument (vlax-get-acad-object)) '("DIM" "LAYER1"))
;;; Аргумент: doc {документ}
;;;           name {список имен слоев}
(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)
    )
  )
)

;;; Очистить все без эха в командной строке
;;; \Пример: (ax:purge-no-echo (vla-get-activedocument (vlax-get-acad-object)))
;;; Аргумент: doc {document}
(defun ax:purge-no-echo (doc)

;;; Возвращает список ключевых имен из указанного словаря
(defun getkeys (dictName / tmp)
  (if (setq tmp (dictsearch (namedobjdict) dictName))
    (massoc 3 tmp)
  )
)

;;; Извлекает имя примитива из указанного словаря
(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
)

;;; Очистить/Удалить все фильтры слоев или все фильтры, 
;;; Пример: (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)
)

;;; Очистить/Удалить все фильтры слоев или все фильтры, 
;;; совместимые с AutoCAD 2005 или более поздним
;;; Пример: (DeleteLayerFilters2)
(defun DeleteLayerFilters2 ()
  (vl-Catch-All-Apply
    '(lambda ()
       (vla-Remove
	 (vla-GetExtensionDictionary
	   (vla-Get-Layers
	     (vla-Get-ActiveDocument (vlax-Get-Acad-Object))
	   )
	 )
	 "AcLyDictionary"
       )
     )
  )
  (princ)
)

;;; Очистить/Удалить все состояния слоев
;;; Пример: (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)
)

;;; Очистить/Удалить все состояния слоев Express Tool
;;; Пример: (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)
)

; Очистит все RegApp или RegApps.
(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)
)