Infinite loop slideshow

[Nando1988]

I would like to create an image slideshow that loops through all the images in all the subfolders in thisworkbook.path with a fade in effect for each image and a 5 second timer delay between each image in an excel userform. I searched in copilot and I have some code, but it currently gives me out of stack space error:

Option Explicit

Dim ImagePaths() As String
Dim CurrentImageIndex As Long

Private Sub UserForm_Initialize()
    ' Initialize the slideshow
    LoadImagePaths
    CurrentImageIndex = 0
    ShowNextImage
End Sub

Private Sub LoadImagePaths()
    ' Load all image file paths from subfolders
    Dim FolderPath As String
    Dim FileExtension As String
    Dim i As Long

    FolderPath = ThisWorkbook.Path
    FileExtension = "*.jpg" ' Change to the desired image file extension

    ReDim ImagePaths(0)
    i = 0

    RecursiveFolderSearch FolderPath, FileExtension, i
End Sub
Private Sub RecursiveFolderSearch(ByVal FolderPath As String, ByVal FileExtension As String, ByRef i As Long)
    Dim FileSystem As Object
    Dim SubFolder As Object
    Dim FileItem As Object

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    Set SubFolder = FileSystem.GetFolder(FolderPath)

    For Each FileItem In SubFolder.Files
        If LCase(Right(FileItem.Name, Len(FileExtension))) = LCase(FileExtension) Then
            ReDim Preserve ImagePaths(i)
            ImagePaths(i) = FileItem.Path
            i = i + 1
        End If
    Next FileItem

    ' Avoid infinite recursion by checking subfolders
    If SubFolder.SubFolders.Count > 0 Then
        For Each SubFolder In SubFolder.SubFolders
            RecursiveFolderSearch SubFolder.Path, FileExtension, i
        Next SubFolder
    End If
End Sub



Private Sub ShowNextImage()
    If CurrentImageIndex < UBound(ImagePaths) Then
        ' Load the image with fade-in effect
        Me.Image1.Picture = LoadPictureWithFadeIn(ImagePaths(CurrentImageIndex))
        CurrentImageIndex = CurrentImageIndex + 1
        Application.OnTime Now + TimeValue("00:00:05"), "ShowNextImage"
    Else
        ' Restart the slideshow
        CurrentImageIndex = 0
        ShowNextImage
    End If
End Sub

Private Function LoadPictureWithFadeIn(ByVal FilePath As String) As IPictureDisp
    ' Load the image with a fade-in effect
    ' You can adjust the duration of the fade-in here
    Dim FadeDuration As Double
    FadeDuration = 1 ' 1 second fade-in

    Dim StartTime As Double
    StartTime = Timer

    Do While Timer < StartTime + FadeDuration
        ' Calculate the opacity based on time
        Dim Opacity As Double
        Opacity = (Timer - StartTime) / FadeDuration

        ' Set the image with opacity
        Set LoadPictureWithFadeIn = LoadPicture(FilePath, Opacity)
        DoEvents
    Loop

    ' Set the final image without opacity
    Set LoadPictureWithFadeIn = LoadPicture(FilePath)
End Function

 

[Domenic]

I have amended your code so that it only creates one instance of the FileSystemObject, instead of creating a new instance each time you want to access a folder.

Also, since you're checking for the file extension using the Right function, I've corrected the value being assigned to your variable.

Then, for clarity, I used a separate variable to distinguish between the folder and subfolder.

By the way, there's no need to check the SubFolders count.

So here's your code, amended as per the above....

Option Explicit

Dim FileSystem As Object
Dim ImagePaths() As String
Dim CurrentImageIndex As Long

Private Sub UserForm_Initialize()
    ' Initialize the slideshow
    LoadImagePaths
    CurrentImageIndex = 0
    ShowNextImage
End Sub

Private Sub LoadImagePaths()
    ' Load all image file paths from subfolders
    Dim FolderPath As String
    Dim FileExtension As String
    Dim i As Long

    FolderPath = ThisWorkbook.Path
    FileExtension = ".jpg" ' Change to the desired image file extension

    ReDim ImagePaths(0)
    i = 0

    RecursiveFolderSearch FolderPath, FileExtension, i
End Sub
Private Sub RecursiveFolderSearch(ByVal FolderPath As String, ByVal FileExtension As String, ByRef i As Long)
    Dim TargetFolder As Object
    Dim SubFolder As Object
    Dim FileItem As Object

    If FileSystem Is Nothing Then
        Set FileSystem = CreateObject("Scripting.FileSystemObject")
    End If
   
    Set TargetFolder = FileSystem.GetFolder(FolderPath)

    For Each FileItem In TargetFolder.Files
        If LCase(Right(FileItem.Name, Len(FileExtension))) = LCase(FileExtension) Then
            ReDim Preserve ImagePaths(i)
            ImagePaths(i) = FileItem.Path
            i = i + 1
        End If
    Next FileItem

    For Each SubFolder In TargetFolder.SubFolders
        RecursiveFolderSearch SubFolder.Path, FileExtension, i
    Next SubFolder
End Sub



Private Sub ShowNextImage()
    If CurrentImageIndex < UBound(ImagePaths) Then
        ' Load the image with fade-in effect
        Me.Image1.Picture = LoadPictureWithFadeIn(ImagePaths(CurrentImageIndex))
        CurrentImageIndex = CurrentImageIndex + 1
        Application.OnTime Now + TimeValue("00:00:05"), "ShowNextImage"
    Else
        ' Restart the slideshow
        CurrentImageIndex = 0
        ShowNextImage
    End If
End Sub

Private Function LoadPictureWithFadeIn(ByVal FilePath As String) As IPictureDisp
    ' Load the image with a fade-in effect
    ' You can adjust the duration of the fade-in here
    Dim FadeDuration As Double
    FadeDuration = 1 ' 1 second fade-in

    Dim StartTime As Double
    StartTime = Timer

    Do While Timer < StartTime + FadeDuration
        ' Calculate the opacity based on time
        Dim Opacity As Double
        Opacity = (Timer - StartTime) / FadeDuration

        ' Set the image with opacity
        Set LoadPictureWithFadeIn = LoadPicture(FilePath, Opacity)
        DoEvents
    Loop

    ' Set the final image without opacity
    Set LoadPictureWithFadeIn = LoadPicture(FilePath)
End Function

Hope this helps!