VideoPhoto

Showing posts with label Photo. Show all posts
Showing posts with label Photo. Show all posts

11 June, 2021

PhotoShow: Looping through images in a folder

There are occasions when you'd like to demonstrate your photos or other images on your computer screen, in a continuous display, each one for predetermined number of seconds, or whatever time span you choose.

This can be quite easily accomplished (automated) with the following VBA macro:

Sub ImageShow()
'Displays images located in a folder on your computer for predetermined times
Dim myFolder As String, myFile As String
Dim imgPath As String
ActiveWindow.DisplayHeadings = False
Application.DisplayScrollBars = False
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayWorkbookTabs = False
Application.DisplayFullScreen = True
Application.DisplayStatusBar = False
Range("A1").Select
'Select your folder (with photos/images only)
MsgBox "Please select your folder with photos/images"
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    myFolder = .SelectedItems(1)
End With
myFile = Dir(myFolder & "\", vbReadOnly)
Do
    imgPath = myFolder & "\" & myFile
    'Open consecutively each image in the selected folder
    ActiveSheet.Shapes.AddPicture Filename:=imgPath, LinkToFile:=msoFalse, _
        SaveWithDocument:=msoTrue, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=-1, Height:=-1
    ActiveSheet.Pictures.Select     'Resize the image to fit screen size
        With Selection
            .ShapeRange.LockAspectRatio = msoTrue
            .ShapeRange.Height = 725    'Change the height to fit your screen size
        End With
    Application.Wait (Now + TimeValue("00:00:05"))
    Range("AA5").Value = myFile        'Change the range if needed for visibility
    DoEvents
    Selection.Delete    'Delete displayed image
    myFile = Dir
    If myFile = "" Then Application.Wait (Now + TimeValue("00:00:05")): Exit Do
Loop While myFile <> ""
Application.DisplayStatusBar = True
ActiveWindow.DisplayHeadings = True
Application.DisplayScrollBars = True
ActiveWindow.DisplayGridlines = True
ActiveWindow.DisplayWorkbookTabs = True
Application.DisplayFullScreen = False
Range("AA5").Value = ""    
'Change the range to match the location set above
End Sub