Rem RenommerFichiersWord_V1_0_0.vbs Rem Renomme un document Word selon son premier paragraphe au format défini dans la variable wdPoliceStyle Rem Renomme aussi la propriété (métadonnée) "Titre" du document Word Rem Consignes: Rem FAITES UNE SAUVEGARDE DES DOCUMENTS À TRAITER ! Rem Indiquer le répertoire d'origine qui contient les documents Word: strDossATraiter Rem Indiquer le répertoire de destination: strDossDestinat. Il doit être différent de strDossATraiter Rem Eventuellement, modifier les caractéres indésirables de début du nom de fichier Rem Eventuellement, modifier les caractéres indésirables de fin du nom de fichier Rem Double cliquer sur le script. Rem Pour arrêter le script en cours d'exécution, démarrer le Gestionnaire des tâches puis dans l'onglet Processus, Rem sélectionner wscript.exe, clic droit puis Terminer l'arborescence du processus et ensuite fermer normalement Word. Rem Basé sur les articles de Hey, Scripting Guy! : http://blogs.technet.com/b/heyscriptingguy/ Rem et Rob van der Woude's Scripting Pages: http://www.robvanderwoude.com/ Rem et http://wsh2.uw.hu/ch06d.html Rem Ce code source est mis dans le domaine public par Claude Couderc, pas de droit d'auteur Rem http://ClaudeCouderc.com/ Rem A utiliser à vos risques et périls Rem Historique: Rem 11/03/2012: Début du développement Rem Todo: Rem - On Error Resume Next Const cstDossATraiter = "Q:\1-Plus-Elevee\BUZ\_Organisation\" ' Dossier contenant les fichiers à traiter. Laissez le \ à la fin Const cstDossDestinat = "Q:\1-Plus-Elevee\BUZ\_Organisation\Clients\" ' Dossier de destination. Laissez le \ à la fin Const cstDossJournal = "Q:\1-Plus-Elevee\BUZ\_Organisation\Clients\MachePro\" ' Dossier d'enregistrement du journal. Laissez le \ à la fin Const cstFichJournal = "journal.log" ' Fichier journal Const cstFichNomRemplacementDeb = "_" ' chaine de remplacement en début de nom de fichier Const cstFichNomRemplacementTou = "" ' chaine de remplacement dans tout le nom de fichier Const cstFichNomRemplacementFin = "" ' chaine de remplacement en fin de nom de fichier Const cstExtDocx = "docx" Const cstExtDoc = "doc" Const cstExtRtf = "rtf" Const cstTempsMaxAttente = 500 Const cstNomFichierLongMax = 255 Const cstEspace = " " Const cstTiret = "-" Const cstPoint = "." Const cstSouligne = "_" Const cstAntiSlash = "\" Const cstFichierAjout = 8 Dim wdPoliceStyle (2) ' Styles de police à chercher dans le documents Rem Permutez les styles si cela présente un intérêt: rapidité, etc. wdPoliceStyle (0) = "Titre" ' 1er style de police recherché dans tout le document wdPoliceStyle (1) = "Titre 1" ' 2ème style de police recherché dans tout le document wdPoliceStyle (2) = "Titre 2" ' 3ème style de police recherché dans tout le document Dim arDebFichNomARemplacer (4) ' Caractères à remplacer en début de nom de fichier Rem Débutez toujours par les chaînes les plus longues puis les plus courtes Rem sinon les résultats sont faussés arDebFichNomARemplacer (0) = "Hey, Scripting Guy! How Can I " ' 1ere chaîne à remplacer en début de nom de fichier arDebFichNomARemplacer (1) = "Hey, Scripting Guy! Can I " ' 2eme chaîne à remplacer en début de nom de fichier arDebFichNomARemplacer (2) = "Hey, Scripting Guy! " ' 3eme chaîne à remplacer en début de nom de fichier arDebFichNomARemplacer (3) = "How Can I " ' 4eme chaîne à remplacer en début de nom de fichier arDebFichNomARemplacer (4) = "Can I " ' 5eme chaîne à remplacer en début de nom de fichier Dim arTouFichNomARemplacer (9) ' Caractères à remplacer dans tout le nom de fichier Rem Il s'agit des caractères interdits dans le nom de fichier Rem Il est déconseillé de supprimer des élements de ce tableau arTouFichNomARemplacer (0) = "\" ' 1ere chaîne à remplacer dans tout le nom de fichier arTouFichNomARemplacer (1) = "/" ' 2eme chaîne à remplacer dans tout le nom de fichier arTouFichNomARemplacer (2) = ":" ' 3eme chaîne à remplacer dans tout le nom de fichier arTouFichNomARemplacer (3) = "*" ' 4eme chaîne à remplacer dans tout le nom de fichier arTouFichNomARemplacer (4) = "?" ' 5eme chaîne à remplacer dans tout le nom de fichier arTouFichNomARemplacer (5) = "<" ' 6eme chaîne à remplacer dans tout le nom de fichier arTouFichNomARemplacer (6) = ">" ' 7eme chaîne à remplacer dans tout le nom de fichier arTouFichNomARemplacer (7) = "/" ' 8eme chaîne à remplacer dans tout le nom de fichier arTouFichNomARemplacer (8) = "|" ' 9eme chaîne à remplacer dans tout le nom de fichier arTouFichNomARemplacer (9) = Chr(34) ' 10eme chaîne à remplacer dans tout le nom de fichier Dim arFinFichNomARemplacer (2) ' Caractères à remplacer en fin de nom de fichier arFinFichNomARemplacer (0) = cstTiret ' 1ere chaîne à remplacer en fin de nom de fichier arFinFichNomARemplacer (1) = cstSouligne ' 2eme chaîne à remplacer en fin de nom de fichier arFinFichNomARemplacer (2) = cstPoint ' 3eme chaîne à remplacer en fin de nom de fichier Rem Corrections automatiques des erreurs éventuelles dans le nom des dossiers strDossATraiter = cstDossATraiter If Right(cstDossATraiter,len(cstAntiSlash)) <> cstAntiSlash Then strDossATraiter = cstDossATraiter & cstAntiSlash strDossDestinat = cstDossDestinat If Right(cstDossDestinat,len(cstAntiSlash)) <> cstAntiSlash Then strDossDestinat = cstDossDestinat & cstAntiSlash If strDossDestinat = strDossATraiter Then Wscript.Echo "ERREUR: le dossier à traiter et le dossier de destination sont identiques:"& vbCrLf & vbTab & strDossDestinat & vbCrLf & "Arrêt du script." Wscript.Quit End If strDossJournal = cstDossJournal If Right(cstDossJournal,len(cstAntiSlash)) <> cstAntiSlash Then strDossJournal = cstDossJournal & cstAntiSlash Rem Demande à l'utilisateur de confirmer le démarrage du programme Set WshShell = WScript.CreateObject("WScript.Shell") Title = "RenommerFichiersWord" Message = "Renomme les documents Word du répertoire " & strDossATraiter & vbCrLf & "selon leur premier paragraphe avec le style '" & wdPoliceStyle (LBound(wdPoliceStyle)) & "'." msg = WshShell.Popup(Message, 0, Title, vbOKCancel + vbQuestion) if msg <> vbOk Then Message = "Action annulée." msg = WshShell.Popup(Message, 0, Title, vbInformation) Wscript.Quit End If cptWord = 0 Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.CreateFolder(strDossJournal) ' Création du dossier journal objFSO.DeleteFile(strDossJournal & cstFichJournal) ' Suppression éventuelle du fichier journal précédent Set objLog = objFSO.OpenTextFile (strDossJournal & cstFichJournal, cstFichierAjout, True) If objFSO.FileExists(strDossJournal & cstFichJournal) Then objLog.WriteLine("Démarrage du programme") Else Wscript.Echo "ERREUR: le fichier journal n'a pas été créé:" & vbCrLf & vbTab & strDossJournal & cstFichJournal & vbCrLf & "Arrêt du script." Wscript.Quit End If objLog.WriteLine("Lecture du répertoire à traiter: " & strDossATraiter) Set objFolder = objFSO.GetFolder(strDossATraiter) Set objWord = CreateObject("Word.Application") objWord.Visible = True For Each objFile in objFolder.Files strFilePath = objFile.Path strName = objFSO.GetFileName(strFilePath) strExtension = objFSO.GetExtensionName(strFilePath) objLog.WriteLine(" Traitement de : " & strName) Rem Vérifie qu'il s'agit de documents Word (ancien format compris) If strExtension = cstExtDocx or strExtension = cstExtDoc or strExtension = cstExtRtf Then Rem Ne traite pas un fichier déjà traité Rem La reconnaissance est faite avec la chaine de remplacement en début de nom de fichier If Left(strName,len(cstFichNomRemplacementDeb)) <> cstFichNomRemplacementDeb Then Set objDoc = objWord.Documents.Open(strFilePath) Set objSelection = objWord.Selection objSelection.Find.Forward = True objSelection.Find.Format = True strText = "" For I = LBound(wdPoliceStyle) to UBound(wdPoliceStyle) objSelection.Find.Style = wdPoliceStyle (I) Do While True objSelection.Find.Execute If objSelection.Find.Found Then strText = strText & objSelection.Text Rem Elimine le retour chariot de la fin de ligne strText = Left(strText,len(strText) - 1) objLog.WriteLine(" Style " & wdPoliceStyle (I) & " trouvé") Rem Se limite au premier wdPoliceStyle rencontré Exit Do Else Exit Do End If Loop Next Rem Si le style wdPoliceStyle a été trouvé if strText <> "" then objSelection.TypeText strText Rem Remplace les caractéres indésirables de début du nom de fichier For I = LBound(arDebFichNomARemplacer) to UBound(arDebFichNomARemplacer) strTextLeft = Left(strText,len(arDebFichNomARemplacer(I))) if strTextLeft = arDebFichNomARemplacer(I) then strTextRight = Right(strText,len(strText) - len(arDebFichNomARemplacer(I))) strText = cstFichNomRemplacementDeb & strTextRight End if Next Rem Remplace les caractéres indésirables de fin du nom de fichier For I = LBound(arFinFichNomARemplacer) to UBound(arFinFichNomARemplacer) strTextRight = Right(strText,len(arFinFichNomARemplacer(I))) if strTextRight = arFinFichNomARemplacer(I) then strTextLeft = Left(strText,len(strText) - len(arFinFichNomARemplacer(I))) strText = strTextLeft & cstFichNomRemplacementFin End if Next Rem Remplace les caractéres indésirables dans tout le nom de fichier Rem Vérifie que les caractéres Windows interdits ne sont pas présents For I = LBound(arTouFichNomARemplacer) to UBound(arTouFichNomARemplacer) strText = Replace(strText,arTouFichNomARemplacer(I),cstFichNomRemplacementTou) Next Rem Elimine les caractéres indésirables en double strText = Replace(strText,cstEspace & cstEspace,cstEspace) ' blanc strText = Replace(strText,cstTiret & cstTiret,cstTiret) ' tiret strText = Replace(strText,cstSouligne & cstSouligne,cstSouligne) ' souligné If Right(strText,len(cstEspace))= cstEspace Then strText = Left(strText,len(strText) - len(cstEspace)) Rem Modifie le titre du document (propriété - metadata) For Each strProperty in objDoc.BuiltInDocumentProperties If strProperty.Name = "Title" Then Rem Elimination dans le titre des caractères de remplacement strTextTitre = strText If Left(strTextTitre,len(cstFichNomRemplacementDeb))= cstFichNomRemplacementDeb Then strTextTitre = Right(strTextTitre,len(strTextTitre) - len(cstFichNomRemplacementDeb)) End If If Right(strTextTitre,len(cstFichNomRemplacementFin))= cstFichNomRemplacementFin Then strTextTitre = Left(strTextTitre,len(strTextTitre) - len(cstFichNomRemplacementFin)) End If strProperty.Value = strTextTitre End if Next Rem Ajoute la chaîne cstFichNomRemplacementDeb en début de fichier si elle est absente If Left(strText,len(cstFichNomRemplacementDeb)) <> cstFichNomRemplacementDeb Then strText = cstFichNomRemplacementDeb & strText Rem Vérifie que la longueur du titre ne dépasse pas le maximum fixé par cstNomFichierLongMax if len(strText) > cstNomFichierLongMax Then strText = Left(strText,cstNomFichierLongMax) Rem Construit le chemin complet de destination objLog.WriteLine(" Nom du fichier: " & strText) strFileName = strDossDestinat & strText & cstPoint & strExtension objDoc.Close Wscript.Sleep cstTempsMaxAttente Rem Renomme le fichier objFSO.MoveFile objFile.Path, strFileName If objFSO.FileExists(strFileName) Then cptWord = cptWord + 1 objLog.WriteLine(" Renommage effectué") Else objLog.WriteLine(" ERREUR: Impossible de renommer en " & strFileName & " Arrêt du script.") Wscript.Echo "ERREUR: Impossible de renommer en " & vbCrLf & vbTab & strFileName & vbCrLf & "Arrêt du script." Wscript.Quit End If Else objLog.WriteLine(" Aucun des styles trouvés") objDoc.Close End If Else objLog.WriteLine(" Fichier Word: déjà traité") End If Else objLog.WriteLine(" Fichier non-Word") End If objLog.WriteLine(cstEspace) Next objWord.Quit Message = "Traitement terminé pour " & cptWord & " fichiers Word." msg = WshShell.Popup(Message, 0, Title, vbInformation) objLog.WriteLine("Fin du programme") objLog.Close