TUTOS.EU

Transformer des images en document html

Comment créer automatiquement un document HTML en VbScript à partir d'images contenues dans un répertoire

De base le nom du fichier servira de description pour l'image dans le document HTML.
Dans ce cadre les 3 premiers caractères du nom du fichier seront supprimés. Ces 3 premiers caractères doivent servir à numéroter les images.
Si une image a un fichier .desc qui porte le même nom, alors cela sera le contenu de ce fichier .desc qui servira de description à l'image dans he HTML.

Le fichier généré ne peut pas être copié/collé dans Word, par contre de word vous pouvez ouvrir le .htm puis l'enregistrer en pdf ou docx

'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("<HTML lang=""fr"">")
objTextFileAEcrire.WriteLine(VbTab & "<Style>")
objTextFileAEcrire.WriteLine(VbTab & "p")
objTextFileAEcrire.WriteLine(VbTab & "{")
objTextFileAEcrire.WriteLine(VbTab & VbTab & "font-size:10pt;font-family:verdana;")
objTextFileAEcrire.WriteLine(VbTab & VbTab & "padding: 0;")
objTextFileAEcrire.WriteLine(VbTab & VbTab & "margin: 0 0 10px 0;")
objTextFileAEcrire.WriteLine(VbTab & "}")
objTextFileAEcrire.WriteLine(VbTab & "")
objTextFileAEcrire.WriteLine(VbTab & ".pImage{")
objTextFileAEcrire.WriteLine(VbTab & VbTab & "position:relative;")
objTextFileAEcrire.WriteLine(VbTab & VbTab & "left:30px;")
objTextFileAEcrire.WriteLine(VbTab & "}")
objTextFileAEcrire.WriteLine(VbTab & "")
objTextFileAEcrire.WriteLine(VbTab & ".pContenuFichier{")
objTextFileAEcrire.WriteLine(VbTab & VbTab & "font-size:10pt;font-family:Consolas;")
objTextFileAEcrire.WriteLine(VbTab & VbTab & "padding: 0 0 0 30px;")
objTextFileAEcrire.WriteLine(VbTab & VbTab & "margin: 0;")
objTextFileAEcrire.WriteLine(VbTab & VbTab & "left:30px;")
objTextFileAEcrire.WriteLine(VbTab & "}")

objTextFileAEcrire.WriteLine(VbTab & "</Style>")
'objTextFileAEcrire.WriteLine(VbTab & "<BODY>")


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("<p>" & objTextFileALire.Readline & "</p>")
					'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("<p class=""pContenuFichier"">" & objTextFileALire.Readline & "</p>")
						'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 & "<p class=""pImage""><img src=""./" & MyFile.Name & """></p>") '</BR>
				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("<p>" & Description & "</p>")
					
					'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("</HTML>")
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
Lien vers le fichier : cliquez ici Copier le code

Article(s) suivant(s)

Convertir un fichier html en fichier word

Article(s) en relation(s)

Retirer les accents d'une chaine de caractères en vbs

Renuméroter en masse des fichiers qui commencent par un chiffre

2