Powerpoint Kiosk VBScript Updater
Using a script from The Scripting Guy Here I'm trying to create a simple presentation updater.
Scenario:
Windows XP Pro attached to the back of a big screen TV. It shares a folder "C:\share" and users connect to it and update a power point presentation "Master.ppsx." The PC looks at c:\share to see if there is an updated version of "Master.ppsx", if there is it- Closes the current presentation
- Copies "Master.ppsx" from "c:\share" to "c:\presentations"
- Presents the new presentation in "c:\presentations"
On Error Resume Next
Const ppAdvanceOnTime = 2 ' Run according to timings (not clicks)
Const ppShowTypeKiosk = 3 ' Run in "Kiosk" mode (fullscreen)
Const ppAdvanceTime = 5 ' Show each slide for 10 seconds
' Open the two power point files to work with them.
Set objFileSys = CreateObject("Scripting.FileSystemObject")
Set CurrentPPT = objFileSys.GetFile("c:\presentations\Master.pptx")
Set NewPPT = objFileSys.GetFile("c:\share\Master.pptx")
' Open the shell object for passing commands.
Set objShell = CreateObject("WScript.Shell")
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Set objPresentation = objPPT.Presentations.Open(currentPPT.Path)
' Apply powerpoint settings
objPresentation.Slides.Range.SlideShowTransition.AdvanceOnTime = TRUE
objPresentation.SlideShowSettings.AdvanceMode = ppAdvanceOnTime
objPresentation.SlideShowSettings.ShowType = ppShowTypeKiosk
objPresentation.Slides.Range.SlideShowTransition.AdvanceTime = ppAdvanceTime
objPresentation.SlideShowSettings.LoopUntilStopped = True
' Run the slideshow
Set objSlideShow = objPresentation.SlideShowSettings.Run.View
Do Until Err <> 0
If NewPPT.DateLastModified > CurrentPPT.DateLastModified Then
objPresentation.Close
objFileSys.CopyFile NewPPT, CurrentPPT, True
Set objSlideShow = objPresentation.SlideShowSettings.Run.View
End If
Loop
objPresentation.Saved = False
objPresentation.Close
objPPT.Quit
The If/Then statement is whats breaking currently. It will close the powerpoint being presented, and copy over the new presentation... but when it goes to present the new slideshow the script just dies.
2015 Edit - Adding current solution in full below for those with questions. Currently running on Win 7 Pro x64. PowerPoint 2010. I also have it minimizing after the powerpoint is presented and cycles through once, while a web page is viewed for a set period of time, then the powerpoint cycles again.
Option Explicit
' ============================================================================
' Title: UpdatePPTX.vbs
' Updated: 4/9/2015
' Purpose: Updates and presents the powerpoint presentation running on the break room presentation kiosk
' Reference: Source: http://blogs.technet.com/b/heyscriptingguy/archive/2006/09/05/how-can-i-run-a-powerpoint-slide-show-from-a-script.aspx
' Script adapted from The Scripting Guy blog above.
' ============================================================================
' Set constants that control how Powerpoint behaves
Public Const ppAdvanceOnTime = 2 ' Advance using preset timers instead of clicks.
Public Const ppShowTypeKiosk = 3 ' Run in "Kiosk" mode (fullscreen)
Public Const ppAdvanceTime = 20 ' Amount of time in seconds that each slide will be shown.
Public Const ppSlideShowPointerType = 4 ' Hide the mouse cursor
Public Const ppSlideShowDone = 5 ' State of slideshow when finished.
' File system manipulation
Public objFileSys 'as Object ' Used to work with files in the file system.
Public CurrentPPT 'as Object ' Used to store the current presentation powerpoint
Public NewPPT 'as Object ' Used to store the new presentation powerpoint
' Objects for Powerpoint manipulation.
Public objSlideShow 'as Object ' The current slide show being presented.
Public objPresentation 'as Object ' The current powerpoint open
Public objPPT 'as Object ' Powerpoint application
' Miscellaneous windows objects.
Public objShell 'as Object ' Used for batch scripting gbmailer notifications
Public objExplorer 'as Object ' Used to control the position of Internet Explorer
' Open the two powerpoint files to work with them.
Set objFileSys = CreateObject("Scripting.FileSystemObject")
Set CurrentPPT = objFileSys.GetFile("C:\Utilities\UpdatePPTX\Presentation\Master.pptm")
Set NewPPT = objFileSys.GetFile("C:\Utilities\UpdatePPTX\Share\Master.pptm")
' Open the shell object for passing commands.
Set objShell = CreateObject("WScript.Shell")
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
On Error Resume Next ' Exits the loop to cleanly close if error.
Do Until Err.Number <> 0
' Compare the two files to see if a new version has been uploaded.
If NewPPT.DateLastModified > CurrentPPT.DateLastModified Then
' If a user is in the middle of an upload, wait so the file can be fully copied to the share
WScript.Sleep(5000)
' Get the newest powerpoint and present it.
CopyNew()
Notify()
End If
Present()
ShowIE()
Loop
' Clean up memory and exit
objPresentation.Saved = True
objSlideShow.Exit
objPresentation.Close
objPPT.Quit
objPPT = Nothing
objPresentation = Nothing
objSlideShow = Nothing
WScript.Quit
' =============================================
' Functions
' =============================================
' =============================================
' CopyNew - Move updated presentation over to presentation folder.
' =============================================
Sub CopyNew()
Dim pptFileName 'as String 'Holds the filename for the History file.
' Copy the powerpoint from C:\Utilities\UpdatePPTX\Share to C:\Utilities\UpdatePPTX\Presentation
objFileSys.CopyFile NewPPT.Path, CurrentPPT.Path, True
pptFileName = Year(Now()) & Month(Now()) & Day(Now()) & "_" & Hour(Now()) & "-" & Minute(Now())
objFileSys.CopyFile NewPPT.Path, "C:\Utilities\UpdatePPTX\Share\History\" & pptFileName & ".pptm"
End Sub
' =============================================
' Notify - Send email when updated.
' =============================================
Sub Notify()
' This sub routine handles smtp email notifications
' Using GBMail send a notification to the people who do presentation updates
' objShell.Run "C:\Utilities\UpdatePPTX\Email\gbmailer\gbmail.exe -v -file C:\Utilities\UpdatePPTX\email.txt -from [from] -h [smtp] -to [To] -s Breakroom_Presentation_Updated", 0
End Sub
' =============================================
' Present PowerPoint
' =============================================
Sub Present()
' Establish the presentation object
S开发者_JAVA百科et objPresentation = objPPT.Presentations.Open(CurrentPPT.Path)
' Apply powerpoint settings
objPresentation.Slides.Range.SlideShowTransition.AdvanceOnTime = TRUE
objPresentation.SlideShowSettings.AdvanceMode = ppAdvanceOnTime
objPresentation.SlideShowSettings.ShowType = ppShowTypeKiosk
objPresentation.Slides.Range.SlideShowTransition.AdvanceTime = ppAdvanceTime
' objPresentation.SlideShowSettings.LoopUntilStopped = True
' Play the new slideshow
Set objSlideShow = objPresentation.SlideShowSettings.Run.View
' Trap loop until the slide show is finished.
Do until objSlideShow.State = ppSlideShowDone
' Make sure mouse stays hidden
objPresentation.SlideShowWindow.View.PointerType = ppSlideShowPointerType
' Make sure PowerPoint is on top. (does nothing)
If objShell.AppActivate("PowerPoint Slide Show - [Master.pptm") <> 1 Then
objShell.AppActivate "PowerPoint Slide Show - [Master.pptm]"
End If
' Make sure PowerPoint remains active so it can play (maintains focus).
objPresentation.SlideShowWindow.Activate
If Err <> 0 Then
Exit Do
End If
Loop
objSlideShow.Exit
objPresentation.Saved = True
objPresentation.Close
End Sub
' =============================================
' Show IE
' =============================================
Sub ShowIE()
Dim colProcesses : Set colProcesses = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery( "Select * From Win32_Process" )
Dim objProcess
Dim intRunning
Dim objItem
' Look through all processes currently running, check if Internet Explorer is running.
intRunning = 0
For Each objProcess in colProcesses
If objProcess.Name = "iexplore.exe" Then
intRunning = 1
End If
Next
' If not running, launch it in full screen and show the KDT Realtime app.
If intRunning = 0 Then
Set objExplorer = WScript.CreateObject("InternetExplorer.Application")
objExplorer.Navigate "paste url here"
objExplorer.Visible = True
objExplorer.FullScreen = True
objExplorer.StatusBar = False
' Wait 5 seconds for IE to load before applying zoom setting.
Wscript.Sleep 5000
' Modify zoom to desired level.
' Can be removed modified based on resolution / screen size
objExplorer.Document.Body.Style.Zoom = "150%"
End If
' Make sure IE is on top.
CreateObject("WScript.Shell").AppActivate objExplorer.document.title
objExplorer.Visible = True
' Show IE for 10 minutes by pausing script.
WScript.Sleep 600000
' Hide IE so the powerpoint can play.
objExplorer.Visible = False
End Sub
I'm not a vbscripter but I think I see the problem.
If NewPPT.DateLastModified > CurrentPPT.DateLastModified Then
objPresentation.Close
objFileSys.CopyFile NewPPT, CurrentPPT, True
' you've closed objPresentation at this point; it no longer exists ' but next you:
Set objSlideShow = objPresentation.SlideShowSettings.Run.View
' which won't fly, because there IS no objPresentation object.
You'll need to do this bit again first; open the new presentation and get a reference to it, set up the show params and THEN you can do the .Run.View trick
Set objPresentation = objPPT.Presentations.Open(currentPPT.Path)
' Apply powerpoint settings objPresentation.Slides.Range.SlideShowTransition.AdvanceOnTime = TRUE objPresentation.SlideShowSettings.AdvanceMode = ppAdvanceOnTime objPresentation.SlideShowSettings.ShowType = ppShowTypeKiosk objPresentation.Slides.Range.SlideShowTransition.AdvanceTime = ppAdvanceTime objPresentation.SlideShowSettings.LoopUntilStopped = True
精彩评论