newscript
dim AppName = "PWB Script: Images to PowerPoint"
dim appVersion = "2023-03-29"
' performance: on my old laptop, about 4500 images per hour
' background.
' I wanted to create a PPT containing a set of images and their thumbnails.
' Approach A:
' In VBA, add a file using oPic = oSlide.shapes.add (..)
' Total file size is too high, 160 images (in file explorer ~ 720 Mb), PPT >600 Mb
' But image position / size / orientation is trivial
' Approach B:
' In VBA, add a file using oPic = oSlide.shapes.add (..)
' then oPic.export, oPic.delete , then oPic = oSlide.shapes.add (.exported file.)
' This reduces the size of the images, the PPT ended up at ~ 32 Mb
' Still too big.
' And image position / size / orientation is complicated
' Approach C (used here):
' control the VBA from Plodware Basic using OLE / automation
' Preprocess each image file using WIA.ImageFile and WIA.ImageProcess
' Reduce the image width/height using a WIA Filter, save as a temporary file.
' Be warned, I picked 300*300 by trial and error. Other values made the end PPT BIGGER!
' Use VBA to oPic = oSlide.shapes.add (..) the temporary file
' End PPT site was down to just over 3 Mb Success!
' And image position / size / orientation is still complicated
' Could have done the preprocessing in VBA but that would be a bit more complicated
' (using references) than in PWB.
' --------------------------------------------------
FUNCTION appDescription ()
freestring = "ZZ" & appVersion & "ZZZZ"
>>Given a folder, this program will scan that folder and its subfolders ZZ
>>for images (currently jpg files). ZZ
>>ZZFor each folder with an image file(s) it will create in that folder ZZ
>>a PowerPoint presentation containing slides holding a thumbnail of the ZZ
>>found images, and one side per image with a larger "thumbnail" of the image.ZZ
>>ZZThis program controls (using Automation / OLE) Microsoft PowerPoint to ZZ
>>create the PPT file. IThe host Windows environment must have a installedZZ
>>copy of the Microsoft PowerPoint executable for this script to function.ZZ
>>ZZ
>>Drag'n'drop a folder on the coloured area above, or on this display panel.
appDescription = replace ( freestring , "ZZ" , chr(0x0a) )
END function
report ()
dbclose
dbopen ("memory")
dim defImgName = "pptimg.jpg"
' --------------------------------------------------
FUNCTION toggleWarnColour ( sobid )
IF ( sob (sobId , "GET", "RGB" ) == rgb ( 0xff, 0x7f, 0x7f ) ) then
sob ( sobId , "SET", "RGB" , RGB ( 0xff ,0,0 ) )
ELSE
sob ( sobId , "SET", "RGB" , rgb ( 0xff, 0x7f, 0x7f ) )
END IF
END FUNCTION
FUNCTION toggleOKColour ( sobid )
IF ( sob (sobId , "GET", "RGB" ) == rgb ( 0x7f, 0xff, 0x7f ) ) then
sob ( sobId , "SET", "RGB" , RGB ( 0 ,0xff ,0 ) )
ELSE
sob ( sobId , "SET", "RGB" , rgb ( 0x7f, 0xff, 0x7f ) )
END IF
END FUNCTION
' create a window to contain some SOBs
dim myWindow = sob ("application","NEW",AppName)
' CALLBACK to handle a click on the TOP Right "X"
FUNCTION XmyWindow ( sobid )
quit
END function
' Associate the callback with myWindow
sob ( myWindow,"ON","CLICK", "XmyWindow")
' -----------------------------------------------------
' CALLBACK to handle a click on the TOP Right "X"
FUNCTION ClickMyWindow ( sobid )
' delete the SOB myWindow , automatically deletes all of its child SOBs
' sob ( myWindow, "delete")
quit
END function
' -----------------------------------------------------
' add a menu bar myWindow
dim myMenuBar = sob (myWindow , "add" , "menu" , "bar" )
' CALLBACK when the menubar is ABOUT to be displayed.
FUNCTION ClickMenuBar ( sobid )
END function
' sob ( myMenuBar , "ON" , "PRESS" , "ClickMenuBar" )
' -----------------------------------------------------
' add horizonal menus to myMenuBar
dim myMenuFile = sob (myMenuBar , "add" , "menu" , "Horizontal" , "File" )
dim myMenuOptions = sob (myMenuBar , "add" , "menu" , "Horizontal" , "Options" )
dim myMenuTools = sob (myMenuBar , "add" , "menu" , "Horizontal" , "Tools" )
' -----------------------------------------------------
' CALLBACK when the OPTIONS menu is ABOUT to be displayed.
' This is the only CALLBACK implemented for a Horizontal MENU
' This is to ensure that the menu option Expert Mode always
' has the correct check state. The Expert window is automatically
' displayed if there is some programming error.
dim ExpertFlag = 0
FUNCTION ClickExpertMode ( sobid )
ExpertFlag = sob( pwsWindow, "GET", "SHOW")
sob(optionsMenuExpert, "SET", "CHECK" ,ExpertFlag)
END function
sob ( myMenuTools , "ON" , "PRESS" , "ClickExpertMode" )
dim myMenuHelp = sob (myMenuBar , "add" , "menu" , "Horizontal" , "Help" )
' -----------------------------------------------------
' 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" )
' 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")
' -----------------------------------------------------
' 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", appDescription() )
toggleOKColour ( AppStatus )
END Function
' add an ABOUT menu item to the HELP menu
sob ( myMenuHelp , "add" , "menu" , "Vertical", "About" )
' Associate the callback with the Help.About menu option
sob ( -1 , "ON" , "CLICK" , "ClickAbout" )
' -----------------------------------------------------
FUNCTION CbClearAppDisplay ( sobid )
sob ( AppDisplay, "EMPTY")
END Function
sob ( myMenuTools , "add" , "menu" , "Vertical", "Clear display area" )
sob ( -1 , "ON" , "CLICK" , "CbClearAppDisplay" )
dim optionsMenuExpert = sob ( myMenuTools , "add" , "menu" , "Vertical" , "Expert Mode" )
FUNCTION cbExpertMode ( sobid )
ExpertFlag = ! sob ( sobid , "GET", "CHECK" )
sob ( pwsWindow, "SET", "SHOW", ExpertFlag )
sob ( sobid , "SET", "CHECK", ExpertFlag )
END function
sob ( -1 , "ON" , "CLICK" , "cbExpertMode")
' ----------------------------------------------------------
' -----------------------------------------------------
' 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 ( AppStatus )
END Function
' add a CONTACT menu item to the HELP menu
sob ( myMenuHelp , "add" , "menu" , "Vertical" , "Contact" )
' Associate the callback with the Help.Contact menu option
sob ( -1 ,"ON","CLICK", "ClickContact")
dim wideColumn = sob ( myWindow , "ADD" , "CONTAINER" , "COLUMN.W")
sob ( wideColumn , "SET" , "STRETCH" , 1 )
' --------------------------------------------------
dim AppStatus = sob ( wideColumn , "ADD" , "LABEL" , " ")
SOB ( "OVERRIDE" , "STYLE+" , 0x00002000)
> ZZ
>> ZZ Drop a folder(s) here to make a PPT per folder ZZ
dim AppCatchArea = sob ( wideColumn , "ADD" , "BUTTON" , "PUSH" , replace ( freestring , "ZZ", chr(0x0a) ) )
dim AppDisplay = sob ( wideColumn , "ADD" , "EDIT.ROWS" , " " , 3 )
sob ( AppDisplay, "empty" )
sob ( AppDisplay, "ADD", "ROW", appDescription() )
' --------------------------------------------------------------------
' user defined parameters
' --------------------------------------------------------------------
' I have written this program to ONLY handle JPG files.
' This is controlled by SELECT statements only accepting files with an EXT of 'jpg'
' The SELECT uses a clause of the form where ext in ('jpg')
' 1) you can extend the filter to accept other image files by modifing the following statement
' 2) the dbFileFind command that creates the FILEs table, automatically sets the EXT column to be lowercase !
' So do NOT use uppercase!
dim extFilter = " EXT in ( 'jpg' ) "
' e.g.
' dim extFilter = " EXT in ( 'jpg' , 'jpeg' ) "
' ---------------------
' the PPT has two components
' the thumbnail page(s)
' the individual image pages
' -----------------------------------------------------
' add menu items to the Options menu
' -----------------------------------------------------
dim EnableThumbNails = 1
sob ( myMenuOptions , "add" , "menu" , "Vertical" , "AppDisplay Thumbnails" )
FUNCTION cbClickThumbnails ( sobid )
EnableThumbNails = ! EnableThumbNails
sob ( sobid , "SET", "CHECK", EnableThumbNails )
END function
sob ( -1 , "ON" , "CLICK" , "cbClickThumbnails")
sob ( -1 , "SET" , "CHECK" , EnableThumbNails )
' ----------------------------------------------------------
dim EnableIndividualImage = 1
sob ( myMenuOptions , "add" , "menu" , "Vertical" , "AppDisplay Individual Images" )
FUNCTION cbClickImages ( sobid )
EnableIndividualImage = ! EnableIndividualImage
sob ( sobid , "SET", "CHECK", EnableIndividualImage )
END function
sob ( -1 , "ON" , "CLICK" , "cbClickImages")
sob ( -1 , "SET" , "CHECK" , EnableIndividualImage )
' ----------------------------------------------------------
dim SeperatePPTs = 1
sob ( myMenuOptions , "add" , "menu" , "Vertical" , "One PPT per Folder" )
FUNCTION cbSingleMultiPPTs ( sobid )
SeperatePPTs = ! SeperatePPTs
sob ( sobid , "SET", "CHECK", SeperatePPTs )
END function
sob ( -1 , "ON" , "CLICK" , "cbSingleMultiPPTs")
sob ( -1 , "SET" , "CHECK" , SeperatePPTs )
' ----------------------------------------------------------
dim VisiblePPT = 0
sob ( myMenuOptions , "add" , "menu" , "Vertical" , "PPT visible" )
FUNCTION cbVisiblePPT ( sobid )
VisiblePPT = ! VisiblePPT
sob ( sobid , "SET", "CHECK", VisiblePPT )
END function
sob ( -1 , "ON" , "CLICK" , "cbVisiblePPT")
sob ( -1 , "SET" , "CHECK" , VisiblePPT )
' --------------------------------------------------------------------
FUNCTION pptVar ( CodeMod )
> Option Explicit ZZ
>>dim oPres as Presentation ZZ
>>dim offsetWidth ZZ
>>dim offsetHeight ZZ
>>dim cellwidth ZZ
>>dim cellheight ZZ
>>dim matrixAcross ZZ
>>dim matrixDown ZZ
>>dim thumbNailIndex ZZ
>>dim thumbNailsPerSlide ZZ
>>dim maxThumbWidth ZZ
>>dim maxThumbHeight ZZ
>>dim maxWidth ZZ
>>dim maxHeight ZZ
>>dim thumbNailRow ZZ
>>dim thumbNailCol ZZ
>>dim maxImgHeight ZZ
>>dim maxImgWidth ZZ
>>
>>PUBLIC sub setParams ( pPres as presentation , nbrImages, path ) ZZ
>> set oPres = pPres ZZ
>> maxImgHeight = oPres.PageSetup.SlideHeight - 20 ZZ
>> maxImgWidth = oPres.PageSetup.SlideWidth / 2 ZZ
>> IF ( nbrImages < 5 ) then ZZ
>> matrixAcross = 2 ZZ
>> matrixDown = 2 ZZ
>> ELSEIF ( nbrImages < 10 ) then ZZ
>> matrixAcross = 3 ZZ
>> matrixDown = 3 ZZ
>> ELSEIF ( nbrImages < 17 ) then ZZ
>> matrixAcross = 4 ZZ
>> matrixDown = 4 ZZ
>> ELSEIF ( nbrImages < 26 ) then ZZ
>> matrixAcross = 5 ZZ
>> matrixDown = 5 ZZ
>> ELSE ZZ
>> matrixAcross = 8 ZZ
>> matrixDown = 5 ZZ
>> END if ZZ
>> dim oTxtBox as ShapeZZ
>> dim oSlide as Slide ZZ
>> thumbNailIndex = 0 ZZ
>> thumbNailsPerSlide = matrixDown * matrixAcross ZZ
>> dim nbrThumbNailPages ZZ
>> nbrThumbNailPages = ( nbrImages + thumbNailsPerSlide - 1) \ thumbNailsPerSlide ZZ
>> thumbNailRow = 0 ZZ
>> thumbNailCol = 0 ZZ
>> cellwidth = oPres.PageSetup.SlideWidth / matrixAcross ZZ
>> cellheight = ( oPres.PageSetup.SlideHeight - 20) / matrixDown ZZ
>> maxThumbWidth = oPres.PageSetup.SlideWidth / (matrixAcross +1) ZZ
>> maxThumbHeight = oPres.PageSetup.SlideHeight / (matrixDown+1) ZZ
>> offsetHeight = (cellheight - maxThumbHeight) / 1 ZZ
>> offsetWidth = (cellWidth - maxThumbWidth ) / 2 ZZ
>> while nbrThumbNailPages ZZ
>> set oSlide = oPres.slides.add ( 1 ,12) ZZ
>> nbrThumbNailPages = nbrThumbNailPages - 1 ZZ
>> set oTxtBox = oSlide.Shapes.AddTextbox( 1 , offsetWidth , 0 , cellwidth*matrixAcross ,offsetHeight ) ZZ
>> oTxtBox.TextFrame.TextRange.Text = path ZZ
>> oTxtBox.TextFrame.TextRange.Font.Size = 8 ZZ
>> wend ZZ
>> set oSlide = nothing ZZ
>> set oTxtBox = nothing ZZ
>>END sub ZZ
CodeMod .InsertLines ( 1, replace ( freestring , "ZZ" , chr(0x0a) ) )
END Function
FUNCTION pptInsertImage ( CodeMod )
>PUBLIC sub InsertImage ( imgFile As String, tmpFile as String , fname as string )ZZ
>> dim oSlide as Slide ZZ
>> set oSlide = oPres.slides.add ( oPres.slides.count ,12) ' 12 = blank slide ZZ
>> dim oPic as Shape ZZ
>> set oPic = oSlide.Shapes.AddPicture (imgFile, False, True,0,0 ) ZZ
>> oPic.LockAspectRatio = -1 ZZ
>> maxWidth = maxImgWidthZZ
>> maxHeight = maxImgHeight ZZ
>> oPic.height=maxImgHeight ZZ
>> IF ( ( oPic.rotation = 90 ) or ( oPic.Rotation = 270 ) ) then ZZ
>> IF oPic.height > oPic.width then ZZ
>> oPic.height = maxWidth ZZ
>> ELSE ZZ
>> oPic.width = maxHeightZZ ZZ
>> oPic.left = ( oPic.height - oPic.width ) / 2 ZZ
>> END IF ZZ
>> ELSE ZZ
>> IF oPic.height > oPic.width then ZZ
>> oPic.height = maxHeightZZ ZZ
>> ELSE ZZ
>> oPic.width = maxWidth ZZ
>> END IF ZZ
>> oPic.top = 0 ZZ
>> oPic.left = 0 ZZ
>> END if ZZ
>> dim oTxtBox as Shape ZZ
>> set oTxtBox = oSlide.Shapes.AddTextbox( 1 , 0 , maxImgHeight , maxImgWidth , 20 ) ZZ
>> oTxtBox.TextFrame.TextRange.Text = tmpFile ZZ
>> oTxtBox.TextFrame.TextRange.Font.Size = 8 ZZ
>> set oPic = nothing ZZ
>> set oTxtBox = nothing ZZ
>> set oSlide = nothing ZZ
>>END sub ZZ
' next command line adds VBA EOL characters to freestring and writes the string
' to the target presentation's code module (uses the function parameter CodeMod )
CodeMod .InsertLines (CodeMod.CountOfLines , replace ( freestring , "ZZ" , chr(0x0a) ) )
END Function
FUNCTION pptInsertThumbNail ( CodeMod )
>PUBLIC sub InsertThumbNail (imgFile As String, fname as string )ZZ
>> dim oPic as Shape ZZ
>> dim slideNbrZZ
>> dim oSlide as SlideZZ
>> thumbNailIndex = thumbNailIndex + 1 ZZ
>> slideNbr = ( thumbNailIndex + thumbNailsPerSlide - 1) \ thumbNailsPerSlide ZZ
>> set oSlide = oPres.Slides( slideNbr) ZZ
>> IF ( thumbNailCol = matrixAcross ) then ZZ
>> thumbNailRow = thumbNailRow + 1 ZZ
>> IF ( thumbNailRow = matrixDown ) then ZZ
>> thumbNailRow = 0 ZZ
>> END if ZZ
>> thumbNailCol = 0 ZZ
>> END If ZZ
>> set oPic = oSlide.Shapes.AddPicture (imgFile, False, True,offsetWidth + (cellwidth * thumbNailCol ), offsetHeight + (cellheight * thumbNailRow)) ZZ
>> oPic.LockAspectRatio = -1 ZZ
>> IF ( ( oPic.rotation = 90 ) or ( oPic.Rotation = 270 ) ) thenZZ
>> IF oPic.height > maxThumbWidth thenZZ
>> oPic.height = maxThumbWidthZZ
>> if ( oPic.width > maxThumbHeight) then oPic.width = maxThumbHeight ZZ
>> oPic.left = offsetWidth + (cellwidth * thumbNailCol ) ZZ
>> ELSEZZ
>> oPic.width = maxThumbHeightZZ
>> oPic.left = oPic.left - cellwidthZZ
>> if ( oPic.height > maxThumbWidth) then oPic.height = maxThumbWidth ZZ
>> oPic.left = oPic.left + maxThumbWidth ZZ
>> END IF ZZ
>> ELSEIF ( oPic.rotation = 180 ) thenZZ
>> IF oPic.height > oPic.width thenZZ
>> oPic.height = maxThumbHeightZZ
>> if ( oPic.width > maxThumbWidth ) then oPic.width = maxThumbWidthZZ
>> ELSEZZ
>> oPic.width = maxThumbWidthZZ
>> if ( oPic.height > maxThumbHeight ) then oPic.height = maxThumbHeightZZ
>> END IF ZZ
>> oPic.top = offsetHeight + (cellheight * thumbNailRow) ZZ
>> oPic.left = offsetWidth + (cellwidth * thumbNailCol ) ZZ
>> ELSEZZ
>> IF oPic.height > maxThumbHeight thenZZ
>> oPic.height = maxThumbHeightZZ
>> if ( oPic.width > maxThumbWidth ) then oPic.width = maxThumbWidthZZ
>> ELSEZZ
>> oPic.width = maxThumbWidthZZ
>> if ( oPic.height > maxThumbHeight ) then oPic.height = maxThumbHeight ZZ
>> END IFZZ
>> oPic.top = offsetHeight + (cellheight * thumbNailRow) ZZ
>> oPic.left = offsetWidth + (cellwidth * thumbNailCol ) ZZ
>> END ifZZ
>> dim oTxtBoxZZ
>> set oTxtBox = oPres.slides( slideNbr ).Shapes.AddTextbox( 1 , cellwidth * thumbNailCol , cellheight * (thumbNailRow +1), cellwidth ,offsetHeight )ZZ
>> oTxtBox.TextFrame.TextRange.Text = fname ZZ
>> oTxtBox.TextFrame.TextRange.Font.Size = 8ZZ
>> set oPic = nothingZZ
>> set oTxtBox = nothing ZZ
>> set oSlide = nothing ZZ
>> thumbNailCol = thumbNailCol +1 zz
>>END sub ZZ
' next command line adds VBA EOL characters to freestring and writes the string
' to the target presentation's code module (uses the function parameter CodeMod )
CodeMod .InsertLines (CodeMod.CountOfLines , replace ( freestring , "ZZ" , chr(0x0a) ) )
END Function
FUNCTION deleteTmpImgFile ( ImgName)
DeleteFileNow ( ImgName )
END Function
FUNCTION InsertImages ( myPres , path )
dim objWIA = CreateObject("WIA.ImageFile")
dim objIP = CreateObject("WIA.ImageProcess")
objIP.Filters.Add ( objIP.FilterInfos("Scale").FilterID )
' these values MASSIVELY influence the end size of the PPT
objIP.Filters(1).Properties("MaximumWidth").value = 300
objIP.Filters(1).Properties("MaximumHeight").value = 300
> delete from FILEs where path like
freestring = freestring & " " & sqlString ( baseFolder )
>> and name like
freestring = freestring & " " & sqlString ( defImgName )
sql ( freestring )
> select count (*) from FILEs where
freestring = freestring & extFilter
>> and path =
freestring = freestring & sqlString ( path )
sql ( freestring )
dim Cnt = qrSingleValue
cancelText( path , 1 )
cancelText ( "Files = " & Cnt ,2)
> select path, name from FILEs where
freestring = freestring & extFilter
>> and path =
freestring = freestring & sqlString ( path )
>> order by name asc
WITHQUERY ( freestring )
deleteTmpImgFile (baseFolder & defImgName )
objWIA.LoadFile ( wqtext(1) & wqtext(2) )
objWIA = objIP.Apply(objWIA)
objWIA.SaveFile ( baseFolder & defImgName )
myPres . application . run ( myPres.name & "!myNewModule.InsertImage" , baseFolder & defImgName , wqtext(1) & wqtext(2), wqText(2) )
cnt = cnt - 1
cancelText( " " & Cnt , 3 )
END withQuery
deleteTmpImgFile (baseFolder & defImgName )
END Function
' --------------------------------------------------------------------
dim baseFolder
FUNCTION InsertThumbNails ( myPres , path , nbrImages )
dim objWIA = CreateObject("WIA.ImageFile")
dim objIP = CreateObject("WIA.ImageProcess")
objIP.Filters.Add ( objIP.FilterInfos("Scale").FilterID )
objIP.Filters(1).Properties("MaximumWidth").value = 300
objIP.Filters(1).Properties("MaximumHeight").value = 300
> delete from FILEs where path like
freestring = freestring & " " & sqlString ( baseFolder )
>> and name like
freestring = freestring & " " & sqlString ( defImgName )
sql ( freestring )
> select count (*) from FILEs where
freestring = freestring & extFilter
>> and path like
freestring = freestring & sqlString ( path )
sql ( freestring )
dim Cnt = qrSingleValue
cancelText( path & chr(0x0a) ,1)
cancelText( "Thumbnails = " & Cnt ,2)
> select path, name from FILEs where
freestring = freestring & extFilter
>> and path =
freestring = freestring & sqlString ( path )
>> order by name asc
WITHQUERY ( freestring )
deleteTmpImgFile (baseFolder & defImgName )
objWIA.LoadFile ( wqtext(1) & wqtext(2) )
objWIA = objIP.Apply(objWIA)
objWIA.SaveFile ( baseFolder & defImgName )
myPres . application . run ( myPres.name & "!myNewModule.InsertThumbNail" , baseFolder & defImgName , wqText(2) )
cnt = cnt - 1
cancelText( " " & Cnt , 3 )
END withQuery
deleteTmpImgFile (baseFolder & defImgName )
END Function
' --------------------------------------------------------------------
FUNCTION handleAfolder ( myPres , path , nbrImages )
CANCELTEXT(path,1)
sob ( AppDisplay, "ADD", "ROW", "Processing " & nbrImages & " images in folder: " & path & chr(0x0a) )
dim hiRes = HiResTime
' ------------------------------------------------------------
' 1 slide per image
IF ( EnableIndividualImage ) then
InsertImages ( myPres , path )
toggleOKColour ( AppStatus )
END if
' ------------------------------------------------------------
' thumbnails
IF ( EnableThumbNails ) then
InsertThumbNails ( myPres , path , nbrImages)
toggleOKColour ( AppStatus )
END If
' ------------------------------------------------------------
hiRes = HiResTime - hiRes
sob ( AppDisplay, "ADD", "ROW", "Time in seconds = " & hiRes / HiResTick & chr(0x0a) )
sob ( AppDisplay, "ADD", "ROW", "Average Time per Slide in seconds = " & hiRes / HiResTick / nbrImages & chr(0x0a) )
END function
' --------------------------------------------------------------------
FUNCTION SetUpPPTapp ()
dim oHostapp = CreateObject( "powerpoint.application" )
IF ( ! oHostapp ) THEN
Message ="Could not create the PowerPoint Application object"
returnValue = 0
EXIT function
END IF
' we do not need to make the PPT application visible, but I do it anyway
IF ( VisiblePPT ) then
oHostapp.visible = 1
END iF
returnValue = oHostapp
END FUNCTION
FUNCTION SetUpPPTpres ( oHostapp , nbrImages )
' create an empty PPT presentation as "host" for the VBA function(s)
' be warned: the TRUE parameter means READONLY
' Further: if you modify this demo for EXCEL, then do NOT make the
' added WORKBOOK read-only, if you do the target FUNCTIONs/SUBs are not accessible!
dim oHostItem = oHostapp.presentations.add ( VisiblePPT )
' add a MODULE to the "host" presentation to hold the VBA function(s)
dim oVBProj
TRY
oVBProj := oHostItem .VBProject
CATCH
Message("You do NOT have access to Options / Trust Center / Trust Center Setting / Macro Settings / Trust access to the VBA project object model", "WARNING")
returnValue = 0
EXIT function
END TRY
dim oVBComp = oVBProj.VBComponents .Add ( 1 ) ' 1 = vbext_ct_StdModule
' not strictly needed in this demo, otherwise the module has a default name from VBA
oVBComp.name = "myNewModule"
' we need to reference the target module when we install the target FUNCTIONs/SUBs, so point at it
dim CodeMod = oVBComp.CodeModule
' now install the target FUNCTIONs/SUBs in the target module
' we pass it the reference to the target module
pptVar(CodeMod)
pptInsertImage(CodeMod)
pptInsertThumbNail(CodeMod)
dim mySlide = oHostItem.slides.add (1 ,12) ' 12 = blank slide
' mySlide.delete
' title
oHostItem.BuiltInDocumentProperties.item(1).value ="Images and Thumbnails"
' author
oHostItem.BuiltInDocumentProperties.item(3).value ="George.Salisbury@RipeTech.com"
' Creation data
oHostItem.BuiltInDocumentProperties.item(11).value = Date
' Company
oHostItem.BuiltInDocumentProperties.item(21).value = "PlodWare"
' Application name
oHostItem.BuiltInDocumentProperties.item(9).value = AppName
returnValue = oHostItem
END FUNCTION
' --------------------------------------------------------------------
dim TotalFiles
FUNCTION handleFolders ( myPPt , basePath )
dim fCnt
dim TargetPPt = "ImagesThumbs.ppt"
IF ( ! EnableIndividualImage ) then
TargetPPt = "ThumbsOnly.ppt"
END if
IF ( ! EnableThumbNails ) then
TargetPPt = "ImagesOnly.ppt"
END If
dim myPres , presPath
IF ( ! SeperatePPTs ) then
> select count (*) from FILEs where
freestring = freestring & extFilter
sql(freestring)
fcnt = qrsingleValue
TotalFiles = TotalFiles + fcnt
' create an empty Presentation
myPres = SetUpPPTpres ( myPPt , fCnt )
report ( "seps " & fCnt )
IF ( ! myPres ) THEN
STOP
END IF
myPres . application . run ( myPres.name & "!myNewModule.SetParams" , myPres , fCnt , basePath)
END IF
WITHQUERY ( "select path from Files group by path ")
presPath = wqText(1)
> select count (*) from FILEs where
freestring = freestring & extFilter
>> and path =
freestring = freestring & sqlString ( wqtext(1) )
sql = freestring
fcnt = qrsingleValue
IF ( fcnt ) then
IF ( SeperatePPTs ) then
' create an empty Presentation
TotalFiles = TotalFiles + fcnt
myPres = SetUpPPTpres ( myPPt , fCnt )
myPres . application . run ( myPres.name & "!myNewModule.SetParams" , myPres , fCnt , wqtext(1) )
handleAfolder ( myPres , wqText(1) , qrSingleValue )
' ------------------------------------------------------------
' tidy up and save PPT
IF ( isFile (presPath & TargetPPt ) ) then
DeleteFileNow (presPath & TargetPPt )
END IF
' for lazy reason, the last slide is empty
myPres.slides.item(myPres.slides.count) . delete
' command to delete the module with the VBA code that we created
myPres.VBProject.VBComponents .remove (myPres.VBProject.VBComponents .item(1))
myPres. saveas ( presPath & TargetPPt)
myPres.close
ELSE
' report ( wqText(1) & " " & fcnt )
handleAfolder ( myPres , wqText(1) , fcnt )
END IF
END if
END WithQuery
IF ( ! SeperatePPTs ) then
IF ( isFile (basePath & TargetPPt ) ) then
DeleteFileNow (basePath & TargetPPt )
END IF
' for lazy reason, the last slide is empty
myPres.slides.item(myPres.slides.count) . delete
' command to delete the module with the VBA code that we created
myPres.VBProject.VBComponents .remove (myPres.VBProject.VBComponents .item(1))
myPres. saveas ( basePath & TargetPPt)
myPres.close
END IF
myPPt.quit
END Function
' --------------------------------------------------------------------
FUNCTION cbCatchFolder ( sobId )
CancelShow (1)
dim totalTime = hirestime
TotalFiles = 0
sob ( AppDisplay, "EMPTY")
drop table if exists Files
baseFolder = getDropData(1)
IF ( isFile ( baseFolder ) == -1 ) THEN
IF ( right ( baseFolder ) == "\\" ) THEN
ELSE
baseFolder= baseFolder & "\\"
END IF
deleteTmpImgFile (baseFolder & defImgName )
dbFileList ( , "files" , baseFolder , -1)
delete from files where not ext in ('jpg', 'jpeg' , 'gif')
' start PPT
dim myPPt = SetUpPPTapp ()
IF ( ! myPPt ) THEN
STOP
END IF
TRY
sob ( AppDisplay, "ADD", "ROW", "Start: " & time & chr(0x0a) )
handleFolders (myPPt , baseFolder)
sob ( AppDisplay, "ADD", "ROW", "Stop: " & time & chr(0x0a) )
CATCH
sob ( AppDisplay, "ADD", "ROW", chr(0x0a) & "CANCELLED" & chr(0x0a) )
myPPt.visible = 1
END try
totalTime = HiResTime - totalTime
sob ( AppDisplay, "ADD", "ROW", chr(0x0a) & "Overall Time in seconds = " & totalTime / HiResTick & " for " & TotalFiles & " files." & chr(0x0a) )
sob ( AppDisplay, "ADD", "ROW", "Overall Average Time per file in seconds = " & totalTime / HiResTick / TotalFiles & chr(0x0a) )
toggleOKColour ( AppStatus)
ELSE
sob ( AppDisplay, "ADD", "ROW", chr(0x0a) & "Invalid input: " & baseFolder & " is not a folder" & chr(0x0a) )
toggleWarnColour ( AppStatus)
END IF
CancelShow (0)
END FUNCTION
' --------------------------------------------------------------------
sob ( AppCatchArea ,"ON" ,"DROP.FILE", "cbCatchFolder")
sob ( AppDisplay ,"ON" ,"DROP.FILE", "cbCatchFolder")
redirectStatusReportingTo ( AppStatus )
redirectReportingTo ( AppDisplay )
toggleOKColour ( AppStatus )
' try https://www.devhut.net/getting-image-properties-exif-metadata-using-wia-in-vba/
' https://stackoverflow.com/questions/58417126/powerpoint-vba-run-application-commandbars
' https://excelvbacode.wordpress.com/the-sendkeys-method/
sob ( pwsWindow ,"SET" ,"SHOW", 0)