newscript
dim appVersion = "2023-03-21"
FUNCTION appDescription ()
freestring = "??" & appVersion & "????"
>>SAVE all slides of selected PPT to a destination folder, as a set of image files. ??
>> note can save to jpg or png see menu Tools ??
>>??
>>This program uses Automation / OLE techniques tp control Microsoft PowerPoint to ??
>>create the PPT file.
>>??The host Windows environment must have an installed??
>>copy of the Microsoft PowerPoint executable for this script to function.??
>> This program requires that PowerPoint allows Trust Access to the VBA project object model ??
>>??
>>Drag'n'drop a PPT file on the coloured area above, or on this display panel.
appDescription = replace ( freestring , "??" , chr(0x0a) )
End Function
' --------------------------------------------------
FUNCTION toggleWarnColour ( sobid )
IF ( sob (sobId , "GET", "RGB" ) == RGB ( 0xff ,0xbf ,0xbf ) ) then
sob ( sobId , "SET", "RGB" , RGB ( 0xff ,0,0 ) )
ELSE
sob ( sobId , "SET", "RGB" , RGB ( 0xff ,0xbf ,0xbf ) )
END IF
END FUNCTION
FUNCTION toggleOKColour ( sobid )
IF ( sob (sobId , "GET", "RGB" ) == RGB ( 0 ,0xff ,0 ) ) then
sob ( sobId , "SET", "RGB" , RGB ( 0x7f ,0xff ,0x7f ) )
ELSE
sob ( sobId , "SET", "RGB" , RGB ( 0 ,0xff ,0 ) )
END IF
END FUNCTION
' --------------------------------------------------
FUNCTION standardisePathOff ( uPath )
standardisePathOff = uPath
IF ( right(uPath, 1 ) == "\\" ) then
standardisePathOff = right ( uPath , -1 )
END if
END function
FUNCTION standardisePathOn ( uPath )
standardisePathOn = uPath
IF ( right(uPath, 1 ) <> "\\" ) then
standardisePathOn = uPath & "\\"
END if
END function
' --------------------------------------------------
FUNCTION deleteFolder ( parentPath )
dim fso = createobject ("Scripting.FileSystemObject")
parentPath = standardisePathOFF ( parentPath)
report ( parentPath )
TRY
fso.deleteFolder ( parentPath )
END try
END function
FUNCTION pptTOjpg ( dstPath , srcFile , fName )
dstPath = dstPath & fName & "\\"
IF ( isFile(srcFile) == 0 ) then
message "input file not found: " & srcFile
EXIT function
END if
deleteFolder ( standardisePathOFF (dstPath ) )
MKDIRPATH ( dstPath )
dim myPres = myPPt.Presentations.open ( srcFile )
dim VBProj = mypres.VBProject
dim VBComp = VBProj.VBComponents .Add ( 1 ) ' vbext_ct_StdModule
VBComp.name ="NewModule"
dim CodeMod = VBComp.CodeModule
dstPath = standardisePathON (dstPath )
' define the VBA macro(s)
> PUBLIC Sub DumpImages( dstPath as string ) ??
>> dim myPres as presentation ??
>> set myPres = ActivePresentation ??
>> dim i ??
>> i= 0 ??
>> dim iTxt ??
>> dim oSlide as slide ??
>> Dim myScale as long ??
>> dim imageType as string ??
if ( sob(OutputJPG, "GET", "CHECK") ) then
>> imageType ="jpg" ??
ELSE
>> imageType ="png" ??
END IF
>> myScale = 3 ??
>> For each oSlide in myPres.Slides ??
>> iTxt = right ( "00000" & i , 3) ??
>> oSlide.Export dstPath & "\pptIm" & iTxt & "." & imageType , imageType , myScale * myPres.PageSetup.SlideWidth , myScale * myPres.PageSetup.Slideheight ??
>> i = i + 1 ??
>> Next oSlide ??
>> myPres.close ??
>> End Sub ??
' add the macro to VBA
CodeMod .InsertLines (1 , replace ( freestring , "??" , chr(0x0a) & chr(0x0d) ) )
' invoke the VBA macro
myPPt . run ( myPres.name & "!DumpImages" , dstPath )
END Function
' pptTOjpg ( "C:\Users\george\Desktop\exported pictures\IPv6\\" , "C:\Users\george\Desktop\PW IPv6 - Service Domains 01.pptx" )
' -------------------------------------------------------------------------------------------------------------
' define a mini GUI
' Idea is that the user drag'n'drops the target presentation
' on to a button
' create a window to contain some SOBs
dim myWindow = sob ("application","NEW","PPT to image per slide")
' Define a callback to handle a click on the TOP Right "X"
FUNCTION XmyWindow ( sobid )
sob ( sobid, "delete")
END function
' Associate the callback with myWindow
sob ( myWindow,"ON","CLICK", "XmyWindow")
' -----------------------------------------------------
' add a menu bar myWindow
dim myMenuBar = sob (myWindow , "add" , "menu" , "bar" )
' ( target , action , qualifier , qualifier )
' add two horizonal menus to myMenuBar
dim myMenuFile = sob (myMenuBar , "add" , "menu" , "Horizontal" , "File" )
' ( target , action , qualifier , qualifier , parameter )
'dim myMenuOptions = sob (myMenuBar , "add" , "menu" , "Horizontal" , "Options" )
' ( target , action , qualifier , qualifier , parameter )
dim myMenuTools = sob (myMenuBar , "add" , "menu" , "Horizontal" , "Tools" )
' ( target , action , qualifier , qualifier , parameter )
dim myMenuHelp = sob (myMenuBar , "add" , "menu" , "Horizontal" , "Help" )
' ( target , action , qualifier , qualifier , parameter )
' -----------------------------------------------------
' add a menu item to the FILE menu
' Note: we are not going to explicitly remember the ID of the menu SOB we are about to create.
' This is a trick, see comment in about 4 lines!
sob ( myMenuFile , "add" , "menu" , "Vertical" , "Exit" )
' target , action , qualifier , qualifier , parameter )
' Associate a click / press on the File.Exit menu option with a callback handler
' Note: a SOB id of -1 always refers to the SOB used in the last SOB command
' If we did not have this, then we would have had to have a DIM in the previous SOB command line
sob ( -1 , "ON" , "CLICK" , "ClickMyWindow")
' ( target , action , qualifier , parameter )
' -----------------------------------------------------
' add a menu item to the TOOLs menu
FUNCTION cbMenuImageType ( sobid )
SOB ( sobid , "SET" , "CHECKS.OFF" )
sob(sobid, "SET", "CHECK" ,1)
END Function
dim OutputPNG= sob ( myMenuTools , "add" , "menu" , "Vertical" , "output as PNG" )
sob ( -1 ,"ON","CLICK", "cbMenuImageType")
dim OutputJPG = sob ( myMenuTools , "add" , "menu" , "Vertical" , "output as JPG" )
sob ( -1 ,"ON","CLICK", "cbMenuImageType")
sob ( -1 , "TRIGGER")
' -----------------------------------------------------
' Define a callback to handle a click on the Help.About menu option (not yet defined)
'
FUNCTION ClickAbout ( sobid )
sob ( AppDisplay, "EMPTY")
sob ( AppDisplay, "ADD", "ROW", replace ( appDescription(), "??", chr(0x0a) ) )
toggleOKColour ( AppCatchArea )
END Function
' add an ABOUT menu item to the HELP menu
sob ( myMenuHelp , "add" , "menu" , "Vertical", "About" )
' ( target , action , qualifier , qualifier , parameter )
' Associate the callback with the Help.About menu option
' Note: we use the -1 trick again
sob ( -1 , "ON" , "CLICK" , "ClickAbout" )
' ( target , action , qualifier , parameter )
' -----------------------------------------------------
FUNCTION CbClearAppDisplay ( sobid )
sob ( AppDisplay, "EMPTY")
END Function
sob ( myMenuTools , "add" , "menu" , "Vertical", "Clear display area" )
sob ( -1 , "ON" , "CLICK" , "CbClearAppDisplay" )
' -----------------------------------------------------
' Define a callback to handle a click on the Help.Contact menu option (not yet defined)
FUNCTION ClickContact ( sobid )
sob ( AppDisplay, "EMPTY")
sob ( AppDisplay, "ADD", "ROW", "E-Mail: George.Salisbury@RipeTech.com" & chr(0x0a) )
toggleOKColour ( AppCatchArea )
END Function
' add a CONTACT menu item to the HELP menu
sob ( myMenuHelp , "add" , "menu" , "Vertical" , "Contact" )
' ( target , action , qualifier , qualifier , parameter )
' Associate the callback with the Help.Contact menu option
' Note: we use the -1 trick again
sob ( -1 ,"ON","CLICK", "ClickContact")
dim wideColumn = sob ( myWindow , "ADD" , "CONTAINER" , "COLUMN.W")
sob ( wideColumn , "SET" , "STRETCH" , 1 )
' --------------------------------------------------
dim myCol = sob(myWindow,"ADD", "CONTAINER","COLUMN.W")
dim myLabel =sob (wideColumn , "ADD", "LABEL", " ")
SOB ( "OVERRIDE" , "STYLE+" , 0x00002000)
> ??
>> ?? Drop PPT file here??
dim AppCatchArea = sob ( wideColumn , "ADD" , "BUTTON" , "PUSH" , replace ( freestring , "??", chr(0x0a) ) )
dim AppDisplay = sob ( wideColumn , "ADD" , "EDIT.ROWS" , " " , 3 )
sob ( AppDisplay, "empty" )
sob ( AppDisplay , "add", "row", appDescription () )
sob ( AppDisplay, "SET", "row" , "top", 1 )
' --------------------------------------------------
FUNCTION handleFile ( fileToHandle )
dim fso = createobject ("Scripting.FileSystemObject")
dim FileName = fso.GetFileName ( fileToHandle )
dim fName = substr( FileName , 1 , instr(FileName, ".") -1 )
dim PathName = fso.GetParentFolderName ( fileToHandle ) & "\\"
sob(myLabel , "SET", "TITLE" , PathName & " - " & FileName & " - " & fName )
pptTOjpg ( PathName, fileToHandle ,fName )
END function
FUNCTION CBCatchDroppedObject ( sobid )
IF ( ! myPPt ) THEN
toggleWarnColour(AppCatchArea)
Message ="Could not create PowerPoint OLE object"
STOP
END IF
IF GetDropCount THEN
dim dropObject = getDropData(1)
handleFile ( dropObject )
toggleOKColour(AppCatchArea)
ELSE
dim dropObject = ""
sob(myLabel , "SET", "TITLE" , dropObject )
toggleWarnColour(AppCatchArea)
END if
END Function
sob ( AppCatchArea ,"ON" ,"DROP.FILE", "CBCatchDroppedObject")
sob ( AppDisplay ,"ON" ,"DROP.FILE", "cbCatchDroppedObject")
toggleOKColour ( AppCatchArea )
dim myPPt = CreateObject( "powerpoint.application" )
IF ( ! myPPt ) THEN
toggleWarnColour(AppCatchArea)
Message ="Could not create PowerPoint OLE object"
STOP
END IF
myPPt.visible = 1