Normally, Excel application displays user interface (ribbon standard) like this (top and bottom parts):
Normally, Excel application displays user interface (ribbon standard) like this (top and bottom parts):
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