;;; - ------------------------------------------------------------------------------- - ;
;;; -                T O O L - C L E A N U P                                          - ;
;;; - ------------------------------------------------------------------------------- - ;
;;; - Beschreibung : Bereinigungstool für verschiedene Objekte                        - ;
;;; - ------------------------------------------------------------------------------- - ;
;;; - Befehle      : GRP-DELALL
;;; -                GRP-DELALLEMPTY
;;; -                PROXY-DELALL
;;; -                UCS-DELALL
;;; -                VIEWS-DELALL
;;; -                PAGESETUPS-DELALL
;;; -                LAYERSTATE-DELETEALL
;;; -                LAYERFILTER-DELETEALL
;;; -                DEL-VBAPROJECTS
;;; -                CLEARALLPDF
;;; -                CLEARPDF
;;; -                CLEARALLIMAGES
;;; -                CLEARUNREFIMAGES
;;; - ------------------------------------------------------------------------------- - ;
;;; - letzte Änderung am : 28.02.2025                                                 - ;
;;; -              durch : Thomas Krüger                                              - ;
;;; - ------------------------------------------------------------------------------- - ;
(if(>=(atof(getvar "ACADVER"))16.0)
(progn   
  (vl-load-com)
  (defun DT:UNDOEND()
    (while(= 8(logand 8 (getvar "undoctl")))
      (vla-endundomark(vla-get-activedocument(vlax-get-acad-object)))
    )      
  )
  (defun DT:UNDOSTART()
    (DT:UNDOEND)
    (vla-startundomark(vla-get-activedocument(vlax-get-acad-object)))
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:GRP-DELALL(ONLYEMPTY? / GRP COUNT OBJS)
    (vl-load-com)
    (setq COUNT 0)
    (vlax-for GRP (vla-get-groups(vla-get-activedocument(vlax-get-acad-object)))
      (setq OBJS(vl-catch-all-apply'vla-get-count(list GRP)))
      (if ONLYEMPTY?
        (if(and(= OBJS 0)     
               (not(vl-catch-all-error-p(vl-catch-all-apply 'vla-delete(list GRP))))
           )
          (setq COUNT(1+ COUNT))
        )
        (if(not(vl-catch-all-error-p(vl-catch-all-apply 'vla-delete(list GRP))))
          (setq COUNT(1+ COUNT))
        )
      )
    )
    COUNT
  )
  (defun C:GRP-DELALL(/ COUNT)
    (DT:UNDOSTART)
    (setq COUNT(DT:GRP-DELALL nil))
    (DT:UNDOEND)
    (if (/= 0 (getvar "CMDECHO"))
      (prompt(strcat "\n" (itoa COUNT) " Gruppen aufgelöst.\n"))
    )
  )
  (defun C:GRP-DELALLEMPTY(/ COUNT)
    (DT:UNDOSTART)
    (setq COUNT (DT:GRP-DELALL 'T))
    (DT:UNDOEND)
    (if (/= 0 (getvar "CMDECHO"))
      (prompt(strcat "\n" (itoa COUNT) " leere Gruppen aufgelöst.\n"))
    )
  )  
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:PROXY-DELALL(/ COUNT1 COUNT2 BLOCK ITEM NAME)
    (setq COUNT1 0 COUNT2 0)
    (vlax-for BLOCK (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object)))
      (if(=(vla-get-isxref  BLOCK):vlax-false)
        (vlax-for ITEM BLOCK
          (if(and(not(vl-catch-all-error-p
                       (setq NAME (vl-catch-all-apply'vla-get-objectname(list ITEM)))
                     )
                 )
                 (=(strcase NAME)"ACDBZOMBIEENTITY")
             )
            (progn
              (setq COUNT1(1+ COUNT1))
              (if(not(vl-catch-all-error-p(vl-catch-all-apply'vla-delete(list ITEM))))
                (setq COUNT2 (1+ COUNT2))
              )
            )
          )
        )      
      )
    )
    (list COUNT1 COUNT2)
  )
  (defun C:PROXY-DELALL(/ COUNT1 COUNT2)
    (DT:UNDOSTART)
    (mapcar 'set '(COUNT1 COUNT2)(DT:PROXY-DELALL))
    (DT:UNDOEND)
    (if (/= 0(getvar "CMDECHO"))
      (prompt (strcat"\n"(itoa COUNT2)" von "(itoa COUNT1) " gefundenen Proxy-Objekten entfernt."))
    )
  )
   
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:UCS-DELALL(/ ITEM COUNT)
    (setq COUNT 0)
    (vlax-for ITEM(vla-get-UserCoordinateSystems(vla-get-ActiveDocument(vlax-get-acad-object)))
      (if(not(vl-catch-all-error-p(vl-catch-all-apply'vla-delete(list ITEM))))
        (setq COUNT (1+ COUNT))
      )
    )
    COUNT
  )
  (defun C:UCS-DELALL(/ COUNT)
    (DT:UNDOSTART)
    (setq COUNT(DT:UCS-DELALL))
    (DT:UNDOEND)
    (if (/= 0 (getvar "CMDECHO"))
      (prompt(strcat"\n"(itoa COUNT)
                     " unreferenzierte benannte Nutzerkoordiantensysteme entfernt.\n"
             )
      )
    )  
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:VIEWS-DELALL(/ ITEM COUNT)
    (setq COUNT 0)
    (vlax-for ITEM(vla-get-views(vla-get-activedocument(vlax-get-acad-object)))
      (if(not(vl-catch-all-error-p(vl-catch-all-apply'vla-delete (list ITEM))))
        (setq COUNT (1+ COUNT))
      )
    )
    COUNT
  )
  (defun C:VIEWS-DELALL()
    (DT:UNDOSTART)
    (setq COUNT(DT:VIEWS-DELALL))
    (DT:UNDOEND)
    (if (/= 0 (getvar "CMDECHO"))
      (prompt(strcat"\n"(itoa COUNT)" benannte Ansichten gefunden und gelöscht.\n"))
    )        
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:PAGESETUPS-DELALL(/ ITEM COUNT)
    (setq COUNT 0)
    (vlax-for ITEM(vla-get-PlotConfigurations(vla-get-ActiveDocument(vlax-get-acad-object)))
      (if(not(vl-catch-all-error-p(vl-catch-all-apply'vla-delete(list ITEM))))
        (setq COUNT (1+ COUNT))
      )
    )
    COUNT
  )
  (defun C:PAGESETUPS-DELALL(/ COUNT)
    (DT:UNDOSTART)
    (setq COUNT(DT:PAGESETUPS-DELALL))
    (DT:UNDOEND)
    (if (/= 0 (getvar "CMDECHO"))
      (prompt(strcat"\n"(itoa COUNT)" benannte Seiteneinrichtungen entfernt.\n"))
    )
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:LAYERSTATE-DELETEALL(/ LSTATELISTE COUNT OBJ)
    (setq COUNT 0)
    (if(and(setq OBJ(vla-get-layers (vla-get-activedocument(vlax-get-acad-object))))
           (=(vla-get-hasextensiondictionary OBJ):vlax-true)
           (setq OBJ(vla-GetExtensionDictionary OBJ))
           (not(vl-catch-all-error-p
                  (setq OBJ(vl-catch-all-apply'vla-item (list OBJ "ACAD_LAYERSTATES")))
               )
           )
       )
      (progn
        (vlax-for LSTATE OBJ
           (if(not(vl-catch-all-error-p(vl-catch-all-apply'vla-delete(list LSTATE))))
             (setq COUNT (1+ COUNT))
           )
        )  
      )  
    )
    COUNT
  )
  (defun C:LAYERSTATE-DELETEALL(/ COUNT)
    (DT:UNDOSTART)
    (setq COUNT(DT:LAYERSTATE-DELETEALL))
    (DT:UNDOEND)
    (if (/= 0 (getvar "CMDECHO"))
      (prompt(strcat"\n"(itoa COUNT)" Layerstände gelöscht.\n"))
    )  
  )    
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:LAYERFILTER-DELETEALL(/ OBJ DICT)
    (setq COUNT 0)
    (if(and(setq OBJ(vla-get-layers (vla-get-activedocument(vlax-get-acad-object))))
           (=(vla-get-hasextensiondictionary OBJ):vlax-true)
           (setq OBJ(vla-GetExtensionDictionary OBJ))
           (or(not(vl-catch-all-error-p
                    (setq DICT(vl-catch-all-apply'vla-item (list OBJ "ACAD_LAYERFILTERS")))
                  )
              )
              (not(vl-catch-all-error-p
                    (setq DICT(vl-catch-all-apply'vla-item (list OBJ "AcLyDictionary")))
                  )
              )
           )   
       )
      (vlax-for ITEM DICT
        (if(not(vl-catch-all-error-p(vl-catch-all-apply'vla-delete(list ITEM))))
          (setq COUNT (1+ COUNT))
        )        
      )
    )
    COUNT
  )
  (defun C:LAYERFILTER-DELETEALL(/ COUNT)
    (DT:UNDOSTART)
    (setq COUNT(DT:LAYERFILTER-DELETEALL))
    (DT:UNDOEND)
    (if (/= 0 (getvar "CMDECHO"))
      (prompt(strcat"\n"(itoa COUNT)" Layerfilter gelöscht.\n"))
    )
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:DEL-VBAPROJECTS(/ ITEM NAME  FOUND?)
    (vlax-for ITEM(vla-get-dictionaries(vla-get-activedocument(vlax-get-acad-object)))
      (if(and(not(vl-catch-all-error-p
                   (setq NAME (vl-catch-all-apply'vla-get-name(list ITEM)))
                 )
             )    
             (=(strcase NAME)"ACAD_VBA")
             (not(vl-catch-all-error-p(vl-catch-all-apply'vla-delete (list ITEM))))
         )
        (setq FOUND? 'T)
      )
    )
    FOUND?
  )
  (defun C:DEL-VBAPROJECTS()
    (DT:UNDOSTART)    
    (if(DT:DEL-VBAPROJECTS)
      (prompt "\nVBA-MACROS entfernt.\n")
      (prompt "\nKeine VBA-MACROS gefunden.\n")
    )
    (DT:UNDOEND)
  )
  ;;; - ------------------------------------------------------------------------------ - ;
  (defun C:CLEARALLPDF(/ LISTE IMAGEDICT DUMMY)
    (DT:UNDOSTART)
    (vlax-for BLOCK (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object)))
      (vlax-for ITEM BLOCK
        (if(=(strcase(vla-get-objectname ITEM))"ACDBPDFREFERENCE")
          (not(vl-catch-all-error-p                   
                (vl-catch-all-apply                                            
                  'vla-delete
                  (list ITEM)
                )
              )
          )
        )  
      )
    )
    (C:CLEARPDF)
    (DT:UNDOEND)
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun C:CLEARPDF( / GETPDFLIST REMOVED L)
    (defun GETPDFLIST(/ DICTLIST DICT OBJ DIR LISTE PDF PDFLIST)
      (if(and(setq DICT (entget (namedobjdict))) 
             (setq DICT (mapcar
                              '(lambda(X)
                                 (if(and(=(car X) 3)(=(type(cdr X))'STR))
                                   (cons (car X)(strcase (cdr X)))
                                   X
                                 )
                               )  
                               DICT
                            )
             )      
             (=(type(setq DICT(cdr(assoc 350(member '(3 . "ACAD_PDFDEFINITIONS")DICT)))))'ENAME)           
             (setq DICTLIST (entget DICT))
         )
        (progn
          (while (assoc 3 DICTLIST)
            (setq NAME    (cdr(car (member(assoc 3 DICTLIST)DICTLIST))))
            (setq PDFDICT(cdr(cadr(member(assoc 3 DICTLIST)DICTLIST))))
            (setq DIR(cdr(assoc 1 (entget PDFDICT))))
            (setq PDFS(vl-remove-if
                        'null
                        (mapcar
                          '(lambda(X / Y)
                             (if(and(=(car X)330)
                                    (=(type (cdr X)) 'ENAME)
                                    (setq Y (entget (cdr X)))
                                    (=(cdr(assoc 0 Y)) "PDFUNDERLAY")
                                )
                               (cdr(assoc -1 Y))
                             )  
                           )
                           (entget PDFDICT)
                         ) 
                      )         
            )
            (setq PDFLIST(cons (list NAME DIR PDFDICT PDFS)PDFLIST))
            (setq DICTLIST (cdr(member(assoc 3 DICTLIST)DICTLIST)))
          )
        )
      )
      PDFLIST
    )
    (DT:UNDOSTART)    
    (setq REMOVED(vl-remove-if
                   'null
                   (mapcar
                      '(lambda(X / Y)
                         (if(and(vl-every 'null (cadddr X))
                                (setq Y(vlax-ename->vla-object (caddr X)))
                                (not(vl-catch-all-error-p                   
                                      (vl-catch-all-apply                                            
                                        'vla-delete
                                        (list Y)
                                      )
                                    )
                                )
                            )
                           (car X)
                         )  
                       )  
                       (GETPDFLIST)
                   )
                 )  
    )
    (DT:UNDOEND)      
    (if(=(setq L(length REMOVED))0)
      (princ "\nEs wurden keine PDFs entfernt.")
      (progn
        (princ "\nEs wurden folgende PDF entfernt:")
        (foreach PDF REMOVED
          (princ "\n---> ")(princ PDF)
        )
        (princ "\n")
      )  
    )
    (princ)
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun C:CLEARALLIMAGES(/ LISTE IMAGEDICT DUMMY)
    (DT:UNDOSTART)
    (vlax-for BLOCK (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object)))
      (vlax-for ITEM BLOCK
        (if(=(strcase(vla-get-objectname ITEM))"ACDBRASTERIMAGE")
          (progn
            (setq LISTE (cons (vla-get-name ITEM)LISTE))
            (not(vl-catch-all-error-p                   
                  (vl-catch-all-apply                                            
                    'vla-delete
                    (list ITEM)
                  )
                )
            )
          )  
        )
      )
    )           
    (vla-regen(vla-get-activedocument (vlax-get-acad-object)) acAllViewports)
    (C:CLEARUNREFIMAGES)
    (DT:UNDOEND)
    (princ)
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun C:CLEARUNREFIMAGES( / GETPICTURELIST REMOVED L)
    (defun GETPICTURELIST(/ DICTLIST DICT OBJ LISTE BILD BILDLIST)
      (if(and(setq DICT (entget (namedobjdict))) 
             (setq DICT (mapcar
                              '(lambda(X)
                                 (if(and(=(car X) 3)(=(type(cdr X))'STR))
                                   (cons (car X)(strcase (cdr X)))
                                   X
                                 )
                               )  
                               DICT
                            )
             )      
             (=(type(setq DICT(cdr(assoc 350(member '(3 . "ACAD_IMAGE_DICT")DICT)))))'ENAME)           
             (setq DICTLIST (entget DICT))
         )
        (progn
          (while (assoc 3 DICTLIST)
            (setq NAME    (cdr(car (member(assoc 3 DICTLIST)DICTLIST))))
            (setq BILDDICT(cdr(cadr(member(assoc 3 DICTLIST)DICTLIST))))
            (setq BILD(mapcar
                        '(lambda(X / Y)
                           (if(and(setq Y (entget (cdr X)))
                                  (setq Y (entget(cdr(assoc 330 Y))))
                                  (=(cdr(assoc 0 Y)) "IMAGE")
                              )
                             (cdr(assoc -1 Y))
                           )  
                         )  
                         (vl-remove-if-not
                           '(lambda(X / Y)
                              (and(=(car X)330)
                                  (=(type (cdr X)) 'ENAME)
                                  (setq Y (entget (cdr X)))
                                  (=(cdr(assoc 0 Y)) "IMAGEDEF_REACTOR")
                              )      
                            )
                           (entget BILDDICT)
                         )
                      )          
            )
            (setq BILDLIST(cons (list NAME BILDDICT BILD)BILDLIST))              
            (setq DICTLIST (cdr(member(assoc 3 DICTLIST)DICTLIST)))
          )
        )
      )
      BILDLIST
    )
    (DT:UNDOSTART)
    (setq REMOVED(vl-remove-if
                   'null
                   (mapcar
                      '(lambda(X / Y)
                         (if(and(vl-every 'null (caddr X))                              
                                (setq Y(vlax-ename->vla-object (cadr X)))
                                (not(vl-catch-all-error-p                   
                                      (vl-catch-all-apply                                            
                                        'vla-delete
                                        (list Y)
                                      )
                                    )
                                )
                            )
                           (car X)
                         )  
                       )  
                       (GETPICTURELIST)
                   )
                 )  
    )
    (DT:UNDOEND)
    (if(=(setq L(length REMOVED))0)
      (princ "\nEs wurden keine Bilder entfernt.")
      (progn
        (princ "\nEs wurden folgende Bilder entfernt:")
        (foreach BILD REMOVED
          (princ "\n---> ")(princ BILD)
        )
        (princ "\n")
      )  
    )
    (princ)
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun CLEANUP:DLG(/ PROPS WRITE-DCL DLG-CHECK DLG-RUN DCLFILE RETURN)
    (defun WRITE-DCL(/ DIR FILE)
      (if(and(setq DIR(vl-filename-mktemp (strcat "CLEANUP.DCL")))
             (setq FILE (open DIR "w"))
         )            
        (progn        
          
          (mapcar
             '(lambda (X)
                (princ (strcat X "\n") FILE)
              )  
             (append
              '( 
              "CLEANUP"
              ": dialog"
              "   { key = DLGTITEL;"
              "   : boxed_row"
              "   { label = \"Löschen von...\" ;"
              "     : column"
              "     {" 
               )
               (apply
                 'append
                 (mapcar
                   '(lambda(X)
                      (list
                        "       : toggle"
                        (strcat "        { label = \"" (cadr X)"\";")
                        (strcat "          key   = \"KEY"(itoa(caddr X))"\" ;")
                        "        }"      
                      )
                    )  
                    PROPS
                 )
               )
              '(
              "     }"  
              "   }"
              "   : row"
              "      {"        
              "        : button"
              "          { label=\"OK\";"
              "            key=\"OK\";"
              "            fixed_width=true;"
              "            width=12;"
              "            alignment=centered;"
              "            mnemonic =\"O\";"
              "            is_default = true;"
              "          }"
              "        : cancel_button"
              "          { label = \"Abbruch\";"
              "            key = \"CANCEL\";"
              "            fixed_width = true;"
              "            width = 12;"
              "            alignment = centered;"
              "            mnemonic =\"A\";"
              "            is_cancel = true;"
              "          }"
              "        : button"
              "         { label = \"Info\";"
              "            key = \"INFO\";"
              "            fixed_width = true;"
              "            width = 12;"
              "            alignment = centered;"
              "            mnemonic =\"I\";"
              "          }"
              "      }"
              "   }"
               )  
             )  
          )
          (close FILE)
          DIR
        )
      )
    )
    ;; - ---------------------------------------------------------------------------- - ;
    (defun DLG-CHECK(/ NR RETURN)      
      (setq NR -1)
      (repeat(length PROPS)        
        (if(=(get_tile (strcat "KEY" (itoa (setq NR(1+ NR)))))"1")
          (setq RETURN (cons (list (car(nth NR PROPS))(cadr(nth NR PROPS)))RETURN))
        )  
      )        
      (reverse RETURN)
    )  
    ;; - ---------------------------------------------------------------------------- - ;
    (defun DLG-RUN(DCLFILE / DLGINFO DLGINDEX ERRMSG RETURN)                          
      (defun DLGINFO( INFOTEXT )
        (or(=(type INFOTEXT)'STR)
           (setq INFOTEXT
             (strcat "=======  CLEANUP  ========\n"
                     "© Th.Krüger 2025 (tk@Cad-od.de)\n"	            
             )
           )
        )
        (alert INFOTEXT)
      )        
      (if(>(setq DLGINDEX (load_dialog DCLFILE))0)
        (if(new_dialog "CLEANUP" DLGINDEX)
          (progn	                
            (set_tile  "DLGTITEL" "CLEANUP ©Th.Krüger 2025")
            (mapcar
              '(lambda(x)
                 (set_tile  (strcat "KEY" (itoa (caddr X))) "1")
               )
               PROPS
            )
            
            (action_tile "OK"            "(setq RETURN (DLG-CHECK))(done_dialog)")
            (action_tile "CANCEL"        "(setq RETURN         nil)(done_dialog)")
            (action_tile "INFO"          "(DLGINFO INFOTEXT)")	    	             
            (start_dialog)
            (unload_dialog DLGINDEX)            
          )
          (alert "Dialog nicht gefunden")
        )
        (alert "Dialog nicht gefunden")
      )    
      RETURN
    )
    ;; - ---------------------------------------------------------------------------- - ;
    (setq PROPS
      (list
        '((C:GRP-DELALL)              "alle Gruppen"                            0)
        '((C:GRP-DELALLEMPTY)         "alle leeren Gruppen"                     1)
        '((C:CLEARALLPDF)             "alle PDFs"                               2)
        '((C:CLEARPDF)                "alle unreferenzierten PDFVerweise"       3)
        '((C:CLEARALLIMAGES)          "alle Pixelbilder"                        4)
        '((C:CLEARUNREFIMAGES)        "alle unreferenzierten PixelbildVerweise" 5)

        '((C:LAYERSTATE-DELETEALL)    "alle Layerstände"                        6)
        '((C:LAYERFILTER-DELETEALL)   "alle Layerfilter"                        7)                     

        '((C:PAGESETUPS-DELALL)       "alle benannten Seiteneinrichtungen"      8)      
        '((C:VIEWS-DELALL)            "alle benannten Ansichten"                9)      
        '((C:UCS-DELALL)              "alle benannten Koordinatensysteme"      10)      
        '((C:PROXY-DELALL)            "alle Proxyobjekte"                      11)
        '((C:DEL-VBAPROJECTS)         "alle eingebetteten VBA-Projekte"        12)
      )
    )
    (if(and(setq DCLFILE(WRITE-DCL))(setq DCLFILE(findfile DCLFILE)))      
      (progn
        (setq RETURN(DLG-RUN DCLFILE))       
        (vl-file-delete DCLFILE)
        RETURN
      )
    )        
  )
  ;; - ------------------------------------------------------------------------------ - ;
  (defun C:CLEANUP(/ FLAGS)
    (if(setq FLAGS(CLEANUP:DLG))
      (progn
        (DT:UNDOSTART)
        (mapcar
         '(lambda(X)
            (princ(strcat"\n\n...lösche "(cadr X)))
            (eval(car X))
          )  
         FLAGS
        )
        (DT:UNDOEND)
      )  
    )  
  )
;; - -------------------------------------------------------------------------------- - ;
)
)
;;; - ------------------------------------------------------------------------------ - ;
(defun CLEANUP:INFO() 
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-CEANUP : Bereinigungstool für verschiedene Objekte" 
      "\n============ "
      "\n(C) Thomas Krüger 2025" 
      "\nE-Mail: tk@cad-od.de"
      "\nBefehlszeilenaufruf : CLEANUP\n"   
    )
  )
  (princ)  
)
;;; - ------------------------------------------------------------------------------- - ;
(CLEANUP:INFO)
(princ)
;;; - ------------------------------------------------------------------------------ - ;

