Использование сценария от The Scripting Guy Здесь Я пытаюсь создать простое средство обновления презентаций.
Сценарий:Windows XP Pro прикреплена к задней панели телевизора с большим экраном.Он разделяет папку «C: \ share», и пользователи подключаются к ней и обновляют презентацию Power Point «Master.ppsx».ПК смотрит на c: \ share, чтобы увидеть, есть ли обновленная версия «Master.ppsx», если она есть
- Закрывает текущую презентацию
- Копирует «Master.ppsx» из «c: \ share» в «c: \ presentation»
- Представляет новую презентацию в "c: \ Presentations"
При ошибке 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
Оператор If / Then ломается в данный момент.Он закроет представляемую PowerPoint и скопирует новую презентацию ... но когда он перейдет к презентации нового слайд-шоу, сценарий просто умирает.
2015 Edit - полное добавление текущего решения ниже для тех, у кого есть вопросы,На данный момент работает на Win 7 Pro x64.PowerPoint 2010. У меня также есть сведение к минимуму после того, как PowerPoint представлен и циклически проходит один раз, в то время как веб-страница просматривается в течение установленного периода времени, а затем PowerPoint снова циклически повторяется.
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
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
' 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