Nettoyer un dossier (et ses sous dossiers)

[(gile)]

Salut,

 

Une routine pour nettoyer un dossier et tous ses sous dossiers de tous les fichiers correspondant aux formats spécifiés.

 

L'utilisateur choisit le dossier dans une petite boite de dialogue (merci Patrick_35),

puis entre les extensions des fichiers à supprimer en les séparant par une virgule, exemple :

bak,log,err,_ls,_dc

 

ATTENTION : les fichiers sont définitivement supprimés, à utiliser avec précaution.

 

;;; GetFolders
;;; Retourne la liste de tous les sous-dossiers du dossier (ou disque) spécifié (chemin)

(defun GetFolders (path / l c)
 (if (setq l (vl-directory-files path nil -1))
   (apply 'append
   (mapcar '(lambda (x)
	      (cons (setq c (strcat path "\\" x)) (GetFolders c))
	    )
	   (vl-remove "." (vl-remove ".." l))
   )
   )
 )
)

;; str2lst
;; Transforme un chaine avec séparateur en liste de chaines
;;
;; Arguments
;; str : la chaine à transformer en liste
;; sep : le séparateur
;;
;; Exemples
;; (str2lst "a b c" " ") -> ("a" "b" "c")
;; (str2lst "1,2,3" ",") -> ("1" "2" "3")
;; (mapcar 'read (str2lst "1,2,3" ",")) -> (1 2 3)

(defun str2lst (str sep / pos)
 (if (setq pos (vl-string-position (ascii sep) str))
   (cons (substr str 1 pos)
  (str2lst (substr str (+ (strlen sep) pos 1)) sep)
   )
   (list str)
 )
)

;;; DirBox -Patrick_35-

(defun DirBox (Message Chemin Drapeau / rep sh)
 (vl-load-com)
 (setq sh (vlax-create-object "Shell.Application"))
 (if (setq
rep (vlax-invoke sh 'browseforfolder 0 Message Drapeau Chemin)
     )
   (setq rep (vlax-get-property (vlax-get-property rep 'self) 'path))
   (setq rep nil)
 )
 (vlax-release-object sh)
 rep
)

;; CleanFolder (gile)
;; Supprime du dossier et de ses sous dossier tous les fichiers
;; aux formats spécifiées (séparateur = virgule).

(defun c:cleanfolder (/ path exts cnt)
 (vl-load-com)
 (and
   (setq path (dirbox "Sélectionnez le dossier à nettoyer" "" 512))
   (setq exts
   (getstring
     "\nEntrez les extensions de fichiers à supprimer (bak,err,log,...): "
   )
   )
   (setq cnt 0)
   (mapcar
     '(lambda (fold)
 (mapcar
   '(lambda (ext)
      (mapcar '(lambda (file)
		 (vl-file-delete
		   (strcat fold "\\" file)
		 )
		 (setq cnt (1+ cnt))
	       )
	      (vl-directory-files
		fold
		(strcat "*." (vl-string-left-trim "." ext))
	      )
      )
    )
   (str2lst exts ",")
 )
      )
     (cons path (getfolders path))
   )
 )
 (princ (strcat "\n\t" (itoa cnt) " fichiers supprimés"))
 (princ)
) 

 

[Edité le 12/10/2007 par (gile)]

[lesourd2]

Salut Gilles

 

Je viens de tester la routine et j'ai le message suivant:

 

Commande:

CLEANFOLDER

Entrez les extensions de fichiers à supprimer (bak,err,log,...): .bak

** ARRET DU PROGRAMME **

; erreur: une erreur est survenue dans la fonction *erreur*type d'argument

incorrect: streamp nil.

 

?

 

Merci quand meme

 

@+

[Matt666]

Ah tiens c'est marrant comme routine ça...

et puis ça démontre bien la puissance du VLISP..

 

Bravo :

[(gile)]

Lesourd,

 

Je suis désolé :calim:

J'espère que tu n'as pas perdu de travail.

 

Je ne comprends pas pourquoi tu as eu cette erreur, tu aurais du avoir : " 0 fichiers supprimés" parceque tu as mis le point devant l'extension, mais pas une erreur.

J'ai fait plusieurs essais avec ou sans point je n'ai pas eu d'erreur.

 

Le message que tu indiques montre une erreur dans la fonction *erreur*, hors il n'y a pas de redéfinition de *error* dans les LISP ci dessus, je pense que ça vient d'ailleurs, mais je ne suis pas sûr, "streamp nil" c'est la première fois que je vois ça.

 

Toujours est-il que je modifie le LISP pour qu'il accepte les extensions avec ou sans le point.

[lesourd2]

Salut Gilles

 

J'ai recopier le code et ça marche

 

Alors là, je trouve cette routine geniale pour faire le menage rapidement !!!

 

Oui :D bravo

 

@+

[Patrick_35]

Salut (gile)

 

Comme tu te sers des boites de dialogues en activex, juste une amélioration possible de ton getstring ;)

 

  (defun InputBox (Titre Message Defaut / users1 valeur)
   (setq users1 (getvar "users1"))
   (acad-push-dbmod)
   (vla-eval (vlax-get-acad-object) (strcat "ThisDrawing.SetVariable \"USERS1\"," "InputBox (\"" Message "\", \"" Titre "\", \"" Defaut "\")"))
   (setq valeur (getvar "users1"))
   (setvar "users1" users1)
   (acad-pop-dbmod)
   valeur
 )

 

(inputbox "Cleanfolder V1.0" "Entrez les extensions de fichiers à supprimer (bak,err,log,...)" "")

 

pour matt666

Une expression vlisp qui utilise l'inputbox du vba

 

ps : (gile), tu peux aussi traiter l'astérisque avec un point car, à mon avis, tu vas y avoir droit ;)

 

@+

 

pps : Un message fantome ;)

 

[Edité le 12/10/2007 par Patrick_35]

[(gile)]

Salut Patrick,

 

J'étais justement en train de mettre des petites boites de dialogue partout.

 

Même une MsgBox pour une confirmation (genre Windows "Etes vous vraiment sûr de vouloir faire ça ?")

 

Merci pour le coup de l'astérisque ;)

 

Donc nouvelle version avec tout plein de boites de dialogue.

 

PS : J'ai eu un mal fou à poster ce message, il y a quelque chose dans le code de MsgBox qui fout le fout tout en l'air si on ne désactive pas les smileys.

 

 

EDIT : j'ai modifié la saisie des fichiers à supprimer pour permettre de mieux cibler.

Il faut désormais utiliser les carctères génériques : *.bak pour tous le fichiers .bak, toto.* pour tous les fichiers toto (quelques soient leurs extension) ou le nom complet du fichier.

 

EDIT2 : les extensions (*.bak,*.sv$,*.ac$ ...) entrées par l'utilisateur sont reproposées par défaut au prochain lancement de LISP.

 

;; ============ ATTENTION ============;;
;;
;; CleanFolder supprime DEFINITIVEMENT les fichiers,
;; à utiliser avec précaution !!!
;;
;;====================================;;

;;; InputBox Ouvre une boite de dialogue pour récupérer une valeur (string)

(defun InputBox	(Titre Message Defaut / *acad* users1 valeur)
 (setq	*acad* (vlax-get-acad-object)
users1 (getvar "users1")
 )
 (acad-push-dbmod)
 (vla-eval *acad*
    (strcat "ThisDrawing.SetVariable \"USERS1\","
	    "InputBox (\""	   Message
	    "\", \""		   Titre
	    "\", \""		   Defaut
	    "\")"
	   )
 )
 (setq valeur (getvar "users1"))
 (setvar "users1" users1)
 (acad-pop-dbmod)
 valeur
)

;;; MsgBox  -Patrick_35-
;;; Ouvre une boite de dialogue pour récupérer la réponse à une question

(defun MsgBox (Titre Boutons Message Time / Reponse WshShell)
 (setq WshShell (vlax-create-object "WScript.Shell"))
 (setq	Reponse	(vlax-invoke
	  WshShell
	  'Popup
	  Message
	  Time
	  Titre
	  (itoa Boutons)
	)
 )
 (vlax-release-object WshShell)
 Reponse
)

;;; DirBox -Patrick_35-

(defun DirBox (Message Chemin Drapeau / rep sh)
 (vl-load-com)
 (setq sh (vlax-create-object "Shell.Application"))
 (if (setq
rep (vlax-invoke sh 'browseforfolder 0 Message Drapeau Chemin)
     )
   (setq rep (vlax-get-property (vlax-get-property rep 'self) 'path))
   (setq rep nil)
 )
 (vlax-release-object sh)
 rep
)

;;; GetFolders
;;; Retourne la liste de tous les sous-dossiers du dossier (ou disque) spécifié (chemin)

(defun GetFolders (path / l c)
 (if (setq l (vl-directory-files path nil -1))
   (apply 'append
   (mapcar '(lambda (x)
	      (cons (setq c (strcat path "\\" x)) (GetFolders c))
	    )
	   (vl-remove "." (vl-remove ".." l))
   )
   )
 )
)

;; str2lst
;; Transforme un chaine avec séparateur en liste de chaines
;;
;; Arguments
;; str : la chaine à transformer en liste
;; sep : le séparateur
;;
;; Exemples
;; (str2lst "a b c" " ") -> ("a" "b" "c")
;; (str2lst "1,2,3" ",") -> ("1" "2" "3")
;; (mapcar 'read (str2lst "1,2,3" ",")) -> (1 2 3)

(defun str2lst (str sep / pos)
 (if (setq pos (vl-string-position (ascii sep) str))
   (cons (substr str 1 pos)
  (str2lst (substr str (+ (strlen sep) pos 1)) sep)
   )
   (list str)
 )
)

;; CleanFolder (gile)
;; Supprime du dossier et de ses sous dossier tous les fichiers
;; aux formats spécifiées (séparateur = virgule).

(defun c:cleanfolder (/ ext-only path exts cnt)
 (vl-load-com)

 ;; Ext-Only Ne conserve que les extensions isolées
 (defun ext-only (str / pos rslt)
   (setq rslt "")
   (while (setq pos (vl-string-position 44 str))
     (if (= "*." (substr str 1 2))
(setq rslt (strcat rslt (substr str 1 (1+ pos)))
      str  (substr str (+ 2 pos))
)
(setq str (substr str (+ 2 pos)))
     )
   )
   (if	(= "*." (substr str 1 2))
     (setq rslt (strcat rslt str))
     (vl-string-right-trim "," rslt)
   )
 )

 (and
   (setq path (dirbox "Sélectionnez le dossier à nettoyer" "" 512))
   (/=	""
(setq exts
       (inputbox
	 "Cleanfolder"
	 "Entrez les types de fichiers à supprimer séparés par des virgules
          \n(*toto.txt,*.bak,*._ls)"
	 (cond ((getenv "CleanFolderExtensions"))
	       ("")
	 )
       )
)
   )
   (= 6
      (msgbox
 "CleanFolder"
 52
 (strcat "Voulez vous vraiment supprimer tous les fichiers\n"
	 exts
	 "\n du dossier\n"
	 path
 )
 10
      )
   )
   (setenv "CleanFolderExtensions" (ext-only exts))
   (setq cnt 0)
   (mapcar
     '(lambda (fold)
 (mapcar
   '(lambda (ext)
      (mapcar '(lambda (file)
		 (vl-file-delete
		   (strcat fold "\\" file)
		 )
		 (setq cnt (1+ cnt))
	       )
	      (vl-directory-files
		fold
		ext
	      )
      )
    )
   (str2lst exts ",")
 )
      )
     (cons path (getfolders path))
   )
   (alert (strcat (itoa cnt) " fichiers supprimés"))
 )
 (princ)
) 

[Edité le 12/10/2007 par (gile)]

 

[Edité le 14/10/2007 par (gile)]

[Patrick_35]

(gile), super lisp :)

 

On pousse le bouchon plus loin en conservant par défaut les extensions de recherche ? (grace aux registres) ;)

 

@+

[(gile)]

On pousse le bouchon plus loin en conservant par défaut les extensions de recherche ?

 

Je viens juste de modifier la saisie des fichiers pour ne pas la limiter aux extensions.

 

Ou alors il faut trier les entrées et ne conserver que celles qui ne sont que des extensions.

 

J'y réfléchi ...

 

EDIT : c'est fait ;)

 

[Edité le 12/10/2007 par (gile)]