Can you help me to improve my lisp

Hello

I've made a lisp that do a snapshot by crete a block and erase unwanted element.

He work fine but i want if it possibble improve to work on all circumstance.

And if it possible add a progress bar.

Thank for your look.

(defun c:fdp (/ doc dictcoll dictlst mspcoll dictcoll contour ss lst ssall bbox file)
  (vl-load-com)
;;;;;; create undo mark
    (setq Doc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
    (vla-EndUndoMark Doc)
    (vla-StartUndoMark Doc)
;;;;;; purge shx
 (vl-load-com)
 (vlax-for item
        (vla-get-textstyles
          (vla-get-ActiveDocument (vlax-get-acad-object))
        )
   (if
     (not
   (vl-filename-extension (setq fname (vla-get-fontfile item)))
     )
      (setq fname (strcat fname ".shx"))
   )
   (cond ((findfile fname) nil)
     ((findfile (strcat (getenv "WINDIR") "\\FONTS\\" fname))
      nil
     )
     (t
      (vla-put-fontfile item "ltypeshp.shx")
     )
   )
 )
;;;;;;;; clean up dict
(setq dictcoll (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))))
(vlax-for di dictcoll
(setq dictlst (cons (vl-catch-all-apply 'vla-get-name (list di)) dictlst))
)
(setq dictlst (reverse dictlst))
(princ dictlst)
(textscr)
(princ)
;;;;;; detach all xref 
(vl-load-com)
(vl-cmdf "_.-xref" "D" "*")
(vl-cmdf "_.-image" "D" "*")
(setq mspcoll (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(vlax-for ent mspcoll
(if 
(or 
(eq (vl-catch-all-apply 'vla-get-objectname (list ent)) "AcDbDwfReference")
(eq (vl-catch-all-apply 'vla-get-objectname (list ent)) "AcDbPdfReference")
(eq (vl-catch-all-apply 'vla-get-objectname (list ent)) "AcDbDgnReference")
(eq (vl-catch-all-apply 'vla-get-objectname (list ent)) "AcDbOle2Frame")
)
(vla-delete ent)
)
)
(setq dictcoll (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object))))
(vlax-for di dictcoll
(if 
(or 
(eq (vl-catch-all-apply 'vla-get-name (list di)) "ACAD_IMAGE_DICT")
(eq (vl-catch-all-apply 'vla-get-name (list di)) "ACAD_PDFDEFINITIONS")
(eq (vl-catch-all-apply 'vla-get-name (list di)) "ACAD_DGNDEFINITIONS")
(eq (vl-catch-all-apply 'vla-get-name (list di)) "ACAD_DWFDEFINITIONS")
)
(progn
(vlax-for d di
(vla-delete d)
)
(vla-delete di)
)
)
)
;;;;;; purge all
(command "_purge" "_all" "*" "n")
;;;;;; zoom etendue
(command "zoom" "et")
;;;;;; create text of layer
(if
(and
(setq pt (getpoint "\nChoisr un point d'insertion "))
(setq pt (trans pt 1 0) i -1
sp (* 1.5 (getvar 'TEXTSIZE))
)
)
(while (setq df (tblnext "LAYER" (null df)))
(entmake
(list
(cons 0 "TEXT")
(cons 7 (getvar 'TEXTSTYLE))
(cons 8 (cdr (assoc 2 df)))
(cons 6 "ByLayer")
(cons 39 0.0)
(cons 62 256)
(cons 10 (setq p1 (polar pt (* 1.5 pi) (* (setq i (1+ i)) sp))))
(cons 40 (getvar 'TEXTSIZE))
(cons 1 (cdr (assoc 2 df)))
(cons 370 -1)
)
)
)
)
;;;;;; delete layers of your choice
 (prompt "\nChoisir des objects pour supprimer les calques ")
 (if (setq ssL (ssget))
   (repeat (setq nL (sslength ssl))
     (if (setq l_name (cdr (assoc 8 (entget (ssname ssL (setq nL (1- nL)))))))
       (progn
         (setq ssE (ssget "_X" (list (cons 8 l_name))))
         (repeat (setq nE (sslength ssE))
           (entdel (ssname ssE (setq nE (1- nE))))
         )
       )
     )
   )
 )
;;;;;; zoom precedent
(command "zoom" "et")
;;;;;; erase text and mtext
(setq sstext (ssget "_X"  '((0 . "TEXT,MTEXT,LEADER"))))
(command "_erase" sstext "")
;;;;;; make layer and set it current
  (entmake
     (list
       (cons 0 "LAYER")
       (cons 100 "AcDbSymbolTableRecord")
       (cons 100 "AcDbLayerTableRecord")
       (cons 2 "FDP")
       (cons 70 0)
       (cons 62 
))
(setvar "CLAYER" "FDP")
;;;;;; ortho activated
(setvar 'orthomode 1)
;;;;;; create a contour
(command "_pline"(while (> (getvar 'cmdactive) 0) (command pause)))
;;;;;; trim just you want
      (setq contour (entlast))
      (if
      (wcmatch (cdr (assoc 0 (entget contour))) "*POLYLINE")
   (progn
     (setq bbox (ACET-ENT-GEOMEXTENTS contour))
     (setq bbox (mapcar '(lambda(x)(trans x 0 1)) bbox))
     (setq lst (ACET-GEOM-OBJECT-POINT-LIST contour 1e-3))
     (ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list contour)))
     (command "_.Zoom" "0.95x")
     (if (null etrim)(load "extrim.lsp"))
     (etrim contour (polar
                 (car bbox)
                 (angle (car bbox)(cadr bbox))
                 (* (distance (car bbox)(cadr bbox)) 1.1)))
     (if (and
           (setq ss (ssget "_CP" lst))
           (setq ssall (ssget "_X" (list (assoc 410 (entget contour)))))
          )
       (progn
         (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
         (foreach e1 lst (ssdel e1 ssall))
         (ACET-SS-ENTDEL ssall)
         )
       )
     )
   )

;;;;;; layer merge
(vlax-for laylist 
(vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))) 
(command "._laymrg" "N" (vla-get-Name laylist) "" "N" "FDP" "Y") 
)
;;;;;; make block
(setq file (strcat (vl-filename-base (getvar 'DWGNAME)) "_X"))
(if (tblsearch "BLOCK" file)
(command "_.-block" (setq file (strcat file "X")) "0,0" "_All" "")
(command "_.-block" file "0,0" "_All" "")
)
(command "_.insert" file "_S" 1 "0,0" "")
;;;;;; rename block
(command "_.rename" "b" file "fdp")
;;;;;; nested block t 0
(if (setq sel (ssget "_X"  '((0 . "INSERT"))))
(repeat (setq idx (sslength sel))
(block->0 (cdr (assoc 2 (entget (ssname sel (setq idx (1- idx)))))))
)
)
(command "_.regen")
;;;;;; end undo mark
 (vla-EndUndoMark Doc)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
(defun block->0 ( blk / ent enx )
(cond
( (member blk lst))
( (setq ent (tblobjname "block" blk))
(while (setq ent (entnext ent))
(entmod (subst-append 8 "0" (subst-append 62 256 (setq enx (entget ent)))))
(if (= "INSERT" (cdr (assoc 0 enx)))
(block->0 (cdr (assoc 2 enx)))
)
)
(setq lst (cons blk lst))
)
)
)
(defun subst-append ( key val lst / itm )
(if (setq itm (assoc key lst))
(subst (cons key val) itm lst)
(append lst (list (cons key val)))
)
)

Progress bar example http://www.afralisp.net/dialog-control-language/tutorials/progress-bar.php