BORNE MULTIMÉDIA SIMPLISSIME

'
' Démarrage du powerpoint et maj par visite du dossier Depot toutes les 5 sec.
' Gestion des bandeaux
'
Const repDep="C:\Borne\Depot"    ' dossier de dépot
Const repExe="C:\Borne\Exec"     ' dossier d'exécution
Const repArc="C:\Borne\Archives" ' dossier d'archivage des anciens ppt (indiquer une chaine vide si pas d'archivage)
Const pptExe="Borne.ppt"      ' fichier powerpoint d'exécution
Const pptLcd="""C:\Program Files\Microsoft Office 2K3\OFFICE11\POWERPNT.EXE"" /s " ' ligne de commande powerpoint (sans nom de fichier)
'Const pptLcd="""C:\Program Files\Microsoft Office\Office10\POWERPNT.EXE"" /s "    ' ligne de commande powerpoint (sans nom de fichier)
Const banLcd="C:\Borne\Bandeau.exe " ' ligne de commande de l'afficheur de bandeau
Const delai=5000              ' nombre de millisecondes entre chaque itération

Dim fso ' objet Scripting.FileSystemObject
Dim shl ' objet WScript.Shell
Dim ppt ' objet powerpoint
Dim htmlNom     ' nom des fichiers HTML en cours (tableau)
Dim htmlDateFic ' date des fichiers HTML en cours (tableau)
Dim htmlDebut   ' horaire de début des fichiers HTML en cours (tableau)
Dim htmlFin     ' horaire de fin des fichiers HTML en cours (tableau)
Dim html        ' objets HTML en cours (tableau)
Dim htmlNb      ' nombre de fichiers HTML en cours
'--------------------------------------------------------------------------------------------------
Dim nom,ext,rep,ficcol,fic,i

' initialisations diverses
htmlNb=0
Set fso = CreateObject("Scripting.FileSystemObject")
Set shl = CreateObject("WScript.Shell")
set ppt=nothing

' on considère que le dossier d'exécution doit contenir un Borne.ppt au démarrage
If Not fso.FileExists(repExe & "\" & pptExe) Then
	msgbox "Fichier " & repExe & "\" & pptExe & " innexistant...",vbCritical,"Borne"
	WScript.Quit
End If

' construction des tableaux html* avec les fichiers présents dans le dossier Exec
Set rep = fso.GetFolder(repExe)
Set ficCol = rep.Files
For Each fic in ficCol
	ext=ucase(fso.GetExtensionName(fic.name))
	If ext="HTM" or ext="HTML" Then ' on ne s'intéresse qu'aux fichiers HTML
		nom=fso.GetFileName(fic.name)
		If fso.FileExists(repDep & "\" & nom) Then
			' le fichier est toujours présent dans Depot
			Call TraiterHtml(nom)
		Else
			' le fichier n'est plus dans Depot -> il a été "déprogrammé" depuis la dernière exécution
			fic.Delete(True)
		End If
	End If
Next

' Boucle principale jusqu'à ce que le powerpoint soit interrompu
do

	call Depot
	WScript.Sleep delai

loop while ppt.Status=0

' avant de quitter, interruption des éventuels HTML qui tourneraient encore
For i=0 To htmlNb-1
	If Not html(i) Is Nothing Then
'		shl.AppActivate htmlNom(i)
'		shl.SendKeys "%{F4}"
		html(i).Terminate
	End If
Next


'--------------------------------------------------------------------------------------------------
Sub Depot()
	'
	' rapatriement d'un éventuel powerpoint présent dans le dossier Dépot
	' lancement du powerpoint si premier appel ou changement de powerpoint
	' traitement des fichiers HTML (bandeau)
	'
	dim maj,ind,log,ficbak,dte,n,s

	' parcours des fichiers powerpoint du dossier Depot
	Set rep = fso.GetFolder(repDep)
	Set ficCol = rep.Files
	maj = false
	For Each fic in ficCol
		ext=ucase(fso.GetExtensionName(fic.name))
		if ext="PPS" or ext="PPT" then ' on ne s'intéresse qu'aux ppt et pps
			if maj then
				' un powerpoint a déjà été trouvé. Si on en trouve d'autres, on les supprime
				' (sinon, ils seraient utilisés 5 secondes plus tard)
				fic.Delete(True)
			else
				' un powerpoint est trouvé. Si le powerpoint courant est en train de tourner,
				' on commence par l'arrêter.
				if not ppt is nothing then ppt.Terminate
				' destruction ou archivage du powerpoint courant
				if repArc="" then
					' pas d'archivage -> destruction du fichier
					fso.DeleteFile repExe & "\" & pptExe,true
				else
					' archivage du fichier
					' récupération de la date du fichier courant
					set ficbak = fso.GetFile(repExe & "\" & pptExe)
					dte = ficbak.DateLastModified
					' construction d'une chaine de date type "yymmddhhmmss"
					s = Right(Cstr(Year(dte)),2) & Right(Cstr(Month(dte)+100),2) & Right(Cstr(Day(dte)+100),2) & Right(Cstr(Hour(dte)+100),2) & Right(Cstr(Minute(dte)+100),2) & Right(Cstr(Second(dte)+100),2)
					' construction du nom de fichier d'archive (ajout date avant le point)
					s = Replace(pptExe,".",s & ".")
					' test si le fichier n'aurait pas déjà été archivé
					if fso.FileExists(repArc & "\" & s) then
						' le fichier existe déjà -> a priori c'est le même : pas besoin de le remettre -> destruction
						ficbak.Delete(True)
					else
						' le fichier n'existe pas déjà -> déplacement/renommage du fichier dans le dossier d'archive
						ficbak.Move(repArc & "\" & s)
					end if
				end if
				' déplacement du powerpoint déposé dans le dossier d'exécution en le renommant Borne.ppt
				fic.Move(repExe & "\" & pptExe)
				' lancement du nouveau powerpoint (asynchrone)
				Set ppt = shl.Exec(pptLcd & """" & repExe & "\" & pptExe & """")
				maj = True
			end if
		end if
	Next
	if ppt is nothing then
		' on est ici si premier appel à Depot() et pas ne nouveau powerpoint dans le dossier Depot
		' lancement du powerpoint (asynchrone)
		Set ppt = shl.Exec(pptLcd & """" & repExe & "\" & pptExe & """")
	end if
	' parcours des fichiers HTML du dossier Depot
	For Each fic in ficCol
		ext=ucase(fso.GetExtensionName(fic.name))
		if ext="HTM" or ext="HTML" then ' on ne s'intéresse qu'aux fichiers HTML
			nom=fso.GetFileName(fic.name)
			ind=ArrayGetIndex(htmlNom,nom)
			If IsNull(ind) Then
				' c'est un nouveau fichier
				fic.Copy(repExe & "\" & nom)
				Call TraiterHtml(nom)
			Else
				' le fichier est déjà réferencé
				If htmlDateFic(ind)<>fic.DateLastModified Then
					' le fichier a été modifié -> il faut le retraiter
					If html(ind) Is Nothing Then
						' on ne peut le retraiter que s'il n'est pas encore en train de tourner
						fic.Copy(repExe & "\" & nom)
						Call TraiterHtml(nom)
					End If
				End If
			End If
		end if
	Next
	' parcours des HTML en attente
	ind=0
	Do While ind<htmlNb
		If html(ind) Is Nothing Then
			' le HTML n'est pas en train de tourner
			If htmlFin(ind)<=Now Or Not fso.FileExists(repDep & "\" & htmlNom(ind)) Then
				' la programmation du fichier appartient au passé
				'    OU
				' le fichier à été supprimé de Depot -> sa programation est annulée
				' on supprime le fichier dans les dossier Exec et Depot
				fso.DeleteFile repExe & "\" & htmlNom(ind),True
				If fso.FileExists(repDep & "\" & htmlNom(ind)) Then
					fso.DeleteFile repDep & "\" & htmlNom(ind),True
				End If
				' on supprime les entrées dans les tableaux
				For i=ind to htmlNb-2
					htmlNom(i)=htmlNom(i+1)
					htmlDateFic(i)=htmlDateFic(i+1)
					htmlDebut(i)=htmlDebut(i+1)
					htmlFin(i)=htmlFin(i+1)
					Set html(i)=html(i+1)
				Next
				htmlNb=htmlNb-1
				If htmlNb=0 Then
					htmlNom=Empty
					htmlDateFic=Empty
					htmlDebut=Empty
					htmlFin=Empty
					html=Empty
				Else
					Redim Preserve htmlNom(htmlNb-1)
					Redim Preserve htmlDateFic(htmlNb-1)
					Redim Preserve htmlDebut(htmlNb-1)
					Redim Preserve htmlFin(htmlNb-1)
					Redim Preserve html(htmlNb-1)
				End If
				ind=ind-1
			ElseIf htmlDebut(ind)<=Now Then
				' il faut le lancer
				Set html(ind) = shl.Exec(banLcd & """" & repExe & "\" & htmlNom(ind) & """")
			End If
		Else
			' le html est en train de tourner
			If htmlFin(ind)<=Now Then
				' il faut l'arrêter
'				shl.AppActivate htmlNom(ind)
'				shl.SendKeys "%{F4}"
				html(ind).Terminate
				set html(ind)=Nothing
			End If
		End If
		ind=ind+1
	Loop
	
	' ecriture du log
	set log=fso.CreateTextFile(repDep & "\" & "log.txt",true)
	set fic=fso.GetFile(repExe & "\" & pptExe)
	log.WriteLine pptExe & " - " & fic.DateLastModified
	n=0
	for i=0 to htmlNb-1
		n=Max(Len(htmlNom(i)),n)
	next
	for i=0 to htmlNb-1
		s=htmlNom(i) & Space(n-Len(htmlNom(i))) & " "
		s=s & htmlDebut(i) & " "
		s=s & htmlFin(i) & " "
		If html(i) Is Nothing Then
			s=s & "En attente"
		Else
			s=s & "Actif"
		End If
		log.WriteLine s
	next
	log.close

	
	' on donne le focus au powerpoint
	' (utile si le script est lancé par le planificateur de tâches)
'	shl.AppActivate "Diaporama PowerPoint"
	shl.AppActivate ppt.ProcessID
End Sub
'--------------------------------------------------------------------------------------------------
Sub TraiterHtml(nom)
	'
	' Ajout d'un fichier HTML dans les tableaux html*
	' lecture de la programmation dans les Métadonnées
	'
	Dim fic,ts,debut,fin,s

	Set fic=fso.GetFile(repExe & "\" & nom)

	' lecture du fichier (métadonnées)
	Set ts=fic.OpenAsTextStream(1) ' 1 = ouverture en lecture
	Do Until ts.AtEndOfStream
		s = Trim(Lcase(ts.ReadLine))
		If Left(s,28)="<meta name=""debut"" content=""" Then
			debut=CDate(Mid(s,29,Len(s)-30))
		ElseIf Left(s,26)="<meta name=""fin"" content=""" Then
			fin=CDate(Mid(s,27,Len(s)-28))
		End If
		If Not(Isempty(debut) Or Isempty(fin)) Then Exit Do
	Loop
	ts.Close
	
	' si début et/ou fin n'ont pas pu être lus, on met Now aux deux
	' comme ça le fichier sera supprimé dès la prochaine itération
	If Isempty(debut) Or Isempty(fin) Then
		debut=Now
		fin=Now
	End If

	' Mise à jour des tableaux
	i=ArrayGetIndex(htmlNom,nom)
	If IsNull(i) Then
		i=htmlNb
		If i=0 Then
			Redim htmlNom(i)
			Redim htmlDateFic(i)
			Redim htmlDebut(i)
			Redim htmlFin(i)
			Redim html(i)
		Else
			Redim Preserve htmlNom(i)
			Redim Preserve htmlDateFic(i)
			Redim Preserve htmlDebut(i)
			Redim Preserve htmlFin(i)
			Redim Preserve html(i)
		End If
		htmlNb=i+1
	End If
	htmlNom(i)=nom
	htmlDateFic(i)=fic.DateLastModified
	htmlDebut(i)=debut
	htmlFin(i)=fin
	Set html(i)=Nothing
End Sub
'--------------------------------------------------------------------------------------------------
function ArrayGetIndex(sourceArray,searchValue)
	Dim i
	If Not IsArray(sourceArray) Then
		ArrayGetIndex=Null
	Else
		For i=0 To Ubound(sourceArray)
			If searchValue=sourceArray(i) Then Exit For
		Next
		If i>Ubound(sourceArray) Then
			ArrayGetIndex=Null
		Else
			ArrayGetIndex=i
		End If
	End If
End Function
'--------------------------------------------------------------------------------------------------
Sub ArrayAppend(sourceArray,appendValue)
	If IsEmpty(sourceArray) Then
		Redim sourceArray(0)
	Else
		Redim Preserve sourceArray(Ubound(sourceArray)+1)
	End If
	sourceArray(Ubound(sourceArray))=appendValue
End Sub
'--------------------------------------------------------------------------------------------------
Function Max(a,b)
	If b>a Then
		Max=b
	Else
		Max=a
	End If
End Function