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 & ".")
					' déplacement/renommage du fichier dans le dossier d'archive
					ficbak.Move(repArc & "\" & s)
				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

Télécharger le zip

19 janvier 2009 10:38:04 :

Pour info : j'ai finalement développé le bandeau défilant

09 février 2009 16:27:54 :

Je propose une mise à jour importante permettant la gestion de bandeaux d'annonce défilants et translucides en surimpression du PowerPoint en cours (sur les conseils de gillardg). Cela utilise des fichiers HTML et un petit visualiseur, exécutable en C#.net dont j'ai joint les sources a toutes fins utiles. Le code VBS a nettement pris de l'embonpoint puisqu'il passe de 68 à 317 lignes. J'ai placé cette nouvelle version dans le dossier Borne.v2 et j'ai laissé la première version dans Borne.v1 pour ceux qui n'utilisent pas les bandeaux. Le bandeau est un petit fichier HTML. On personnalisera le message en éditant directement le fichier HTML. Les heures de début et de fin d'affichage du bandeau sont également codées dans le fichier HTML derrière des balises meta "Debut" et "Fin". Toutes ces opérations sont très simples, pas besoin de connaitre le HTML pour comprendre comment mettre à jour le bandeau (avec le jeu de fichiers joint) et l'avantage du HTML est que celui-ci est complètement personnalisable. Une fois le fichier HTML prêt, il suffit, comme pour le Powerpoint, de le déposer dans le dossier de dépôt. Il est possible de programmer à l'avance plusieurs bandeaux, voire même avec chevauchements (dans ce cas, pour une meilleure lisibilité, il vaudra mieux en placer un en bas et l'autre en haut de l'écran...) !

09 février 2009 16:37:55 :

Mise en ligne de la version 2 : gestion des bandeaux défilants.

09 février 2009 16:51:02 :

Mise en ligne de la version 2 : gestion des bandeaux défilants.

09 février 2009 16:59:48 :

J'ai intégré l'option d'archivage de Kopilotk dans la v2