'Version du 08/08/2016 'Permet de transformer des images d'un répertoire en document html Dim objFSO 'Objet FSO pour l'accès au système de fichiers Dim MyFile 'Représente un fichier Dim objTextFileAEcrire, objTextFileALire, objTextFileDesc Dim CheminFichier, CheminFichierDesc, NomFichierSansExtension, NomFichierSansExtensionSansAccents, ExtensionFichier, Position Dim Description 'Déclaration des constantes pour la lecture et l'ecriture dans les fichiers Const ForReading = 1 Const ForWritting = 2 Const ForAppending = 8 CheminScriptActuel = Left(wscript.scriptfullname,Len(wscript.scriptfullname)-Len(wscript.scriptname)-1) CheminRepertoireAExplorer = CheminScriptActuel CheminFichier = CheminScriptActuel & "\ZZMonFichier.htm" 'Création des objets Set objFSO = CreateObject("Scripting.FileSystemObject") 'On fait un objet qui représente le répertoire à explorer Set objFolder = objFSO.GetFolder(CheminRepertoireAExplorer) Set objTextFileAEcrire = objFSO.OpenTextFile(CheminFichier, ForWritting, True) objTextFileAEcrire.WriteLine("") objTextFileAEcrire.WriteLine(VbTab & "") 'objTextFileAEcrire.WriteLine(VbTab & "") For Each MyFile In objFolder.Files Description = "" ExtensionFichier = "" Position = InStrRev(MyFile.Name,".") If (Position > 0) And (Position < Len(MyFile.Name)) Then ExtensionFichier = Mid(MyFile.Name,Position+1) NomFichierSansExtension = Left(MyFile.Name,Position-1) Description = NomFichierSansExtension 'Valeur par défaut If ((Lcase(ExtensionFichier) = "txt") or (Lcase(ExtensionFichier) = "vbs") or (Lcase(ExtensionFichier) = "ps1") or (Lcase(ExtensionFichier) = "bat") Or (Lcase(ExtensionFichier) = "png") Or (Lcase(ExtensionFichier) = "jpg") Or (Lcase(ExtensionFichier) = "jpeg") Or (Lcase(ExtensionFichier) = "tif") Or (Lcase(ExtensionFichier) = "bmp")) Then Do while Len(NomFichierSansExtension) > 60 'Tant que cela dépasse un certain nombre de caractères, on raccourci le nom du fichier 'Wscript.Echo "Le fichier fait plus de 60 caractères : " & NomFichierSansExtension Position = InStrRev(NomFichierSansExtension," ") If (Position > 0) Then NomFichierSansExtension = Left(NomFichierSansExtension, Position-1) Else NomFichierSansExtension = Left(NomFichierSansExtension, 60) 'Si il n'y a plus d'espace, on coupe net End If Loop 'On retire les caractères accentués du nom du fichier NomFichierSansExtensionSansAccents = FctReplace(NomFichierSansExtension) 'On retire les ' _ , NomFichierSansExtensionSansAccents = Replace(NomFichierSansExtensionSansAccents, "'", " ") NomFichierSansExtensionSansAccents = Replace(NomFichierSansExtensionSansAccents, "-", " ") NomFichierSansExtensionSansAccents = Replace(NomFichierSansExtensionSansAccents, ",", "") NomFichierSansExtensionSansAccents = Replace(NomFichierSansExtensionSansAccents, " ", "_") 'Si le fichier comportait des accents ou si il etait trop long, il faut le renommer If NomFichierSansExtensionSansAccents <> NomFichierSansExtension Then Wscript.Echo "On renomme " & MyFile.Name & " en " & NomFichierSansExtensionSansAccents & "." & ExtensionFichier MyFile.Name = NomFichierSansExtensionSansAccents & "." & ExtensionFichier NomFichierSansExtension = NomFichierSansExtensionSansAccents 'Set MyFile = objFSO.GetFile(CheminRepertoireAExplorer & "\" & NomFichierOriginal) 'MyFile.Name = NomFichierRenomme 'Set MyFile = Nothing End If 'On regarde dans un premier temps si un fichier de description (.desc) est associé CheminFichierDesc = CheminRepertoireAExplorer & "\" & NomFichierSansExtensionSansAccents & ".desc" 'Wscript.Echo VbTab & "Test de " & CheminFichierDesc If objFSO.FileExists(CheminFichierDesc) = True Then 'Si le fichier .desc existe Wscript.Echo VbTab & "Fichier de description trouvé pour " & MyFile.Name Set objTextFileALire = objFSO.OpenTextFile(CheminFichierDesc, ForReading, True) Description = "" 'Pour toutes les lignes du fichier Do Until objTextFileALire.AtEndOfStream 'Description = objTextFileALire.Readline 'Lecture et affichage de la ligne 'objTextFileAEcrire = objTextFileALire.Readline objTextFileAEcrire.WriteLine("

" & objTextFileALire.Readline & "

") 'Wscript.Echo MaLigne Loop objTextFileALire.Close Set objTextFileALire = Nothing 'On incorpore maintenant le contenu du fichier. 'Si c'est un fichier texte ou autre, on ouvre le fichier pour le lire If ((Lcase(ExtensionFichier) = "txt") or (Lcase(ExtensionFichier) = "vbs") or (Lcase(ExtensionFichier) = "ps1") or (Lcase(ExtensionFichier) = "bat")) Then Set objTextFileALire = objFSO.OpenTextFile(CheminRepertoireAExplorer & "\" & NomFichierSansExtensionSansAccents & "." & ExtensionFichier, ForReading, True) 'Pour toutes les lignes du fichier Do Until objTextFileALire.AtEndOfStream 'Description = objTextFileALire.Readline 'Lecture et affichage de la ligne 'objTextFileAEcrire = objTextFileALire.Readline objTextFileAEcrire.WriteLine("

" & objTextFileALire.Readline & "

") 'Wscript.Echo MaLigne Loop objTextFileALire.Close Set objTextFileALire = Nothing Else 'Sinon par défaut on considère que c'est une image objTextFileAEcrire.WriteLine(VbTab & "

") '
End If Else 'Si le fichier .desc n'existe pas 'Le nom du fichier servira de description pour l'image If Len(Description) > 3 Then Description = Mid(Description, 4) objTextFileAEcrire.WriteLine("

" & Description & "

") 'Pour la fois d'après on crée le .desc qui permettra une description plus complète Set objTextFileDesc = objFSO.OpenTextFile(CheminFichierDesc, ForWritting, True) objTextFileDesc.WriteLine(Description) objTextFileDesc.Close 'Fermeture du fichier Set objTextFileDesc = Nothing End If End If End If End If Next objTextFileAEcrire.WriteLine("") objTextFileAEcrire.Close 'Fermeture du fichier Set objFolder = Nothing Set objFSO = Nothing Public Function FctReplace(ByVal MaChaine) Dim ListeCaracteresDorigine, ListeCaracteresRemplacement, ArrayCaracteresDorigine, ArrayCaracteresRemplacement, CompteurTableau ListeCaracteresDorigine = "À;Á;Â;Ã;Ä;Å;Ç;È;É;Ê;Ë;Ì;Í;Î;Ï;Ò;Ó;Ô;Õ;Ö;Ù;Ú;Û;Ü;Ý;à;á;â;ã;ä;å;ç;è;é;ê;ë;ì;í;î;ï;ð;ò;ó;ô;õ;ö;ù;ú;û;ü;ý;ÿ" ListeCaracteresRemplacement = "A;A;A;A;A;A;C;E;E;E;E;I;I;I;I;O;O;O;O;O;U;U;U;U;Y;a;a;a;a;a;a;c;e;e;e;e;i;i;i;i;o;o;o;o;o;o;u;u;u;u;y;y" ArrayCaracteresDorigine = Split(ListeCaracteresDorigine, ";") ArrayCaracteresRemplacement = Split(ListeCaracteresRemplacement, ";") For CompteurTableau = Lbound(ArrayCaracteresDorigine) To Ubound(ArrayCaracteresDorigine) MaChaine = Replace(MaChaine, ArrayCaracteresDorigine(CompteurTableau), ArrayCaracteresRemplacement(CompteurTableau)) Next FctReplace = MaChaine End Function