Slideshow need help please

Hello all, I was wondering if someone could tell me an easy way to make this happen with the current slideshow code I am using. Here is what I would like to do, while the slideshow is running if I see a picture in the slideshow I would like to be able to left click on that image and have it set as my wallpaper. Here is the current code I'm using for the slideshow....
Thanks in advance

Dim files
Dim picscount
Dim grpofpics
Dim numofpics
Dim validpics
Dim foldercheck
Dim fs
Dim f
Dim f1
Dim fc

'Called when the script is executed
Sub Object_OnScriptEnter
picscount = 0
End Sub
Sub Object_OnDropFiles(files)
object.KillTimer 1
grpofpics = ""

'Files have extensions (.bmp), a folder does not
'We search the string to see if it contains a period
foldercheck = Instr(1, files, ".")
'If user drops a folder, get files within folder
If foldercheck = 0 Then
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(files)
Set fc = f.Files
For Each f1 In fc
'Check file extensions for valid images
checkext = Split(f1.name,".")
extension = LCase(checkext(1))
'Create a variable, listing only valid image files in folder
If extension = "bmp" Or extension = "png" _
Or extension = "ico" Or extension = "jpg" _
Or extension = "tga" Then
grpofpics = grpofpics & f & "\" & f1.name & "|"
End If
Next
'If there are images found, create array and count images
If grpofpics <> "" Then
grpofpics = Left(grpofpics, Len(grpofpics)-1)
grpofpics = Split(grpofpics, "|")
numofpics = UBound(grpofpics)
End If

'If user drops files
ElseIf foldercheck > 0 Then
grpofpics= Split(files, "|")
For Each elem In grpofpics
'Check file extensions for valid images
checkext = Instr(f1.name, ".")
If checkext > 0 Then
checkext = Split(f1.name,".")
extension = LCase(checkext(1))
End If
'Create a variable, listing only valid image files in folder
If extension = "bmp" Or extension = "png" _
Or extension = "ico" Or extension = "jpg" _
Or extension = "tga" Then
validpics= validpics & elem & "|"
End If
Next
'If there are images found, create array and count images
If validpics <> "" Then
validpics = Left(validpics, Len(validpics)-1)
grpofpics = Split(validpics, "|")
numofpics = UBound(grpofpics)
Else
grpofpics = ""
End If
End If

'If grpofpics contains images, set first picture on drop and add to picscount
If IsArray(grpofpics) = True Then
Object.Picture = grpofpics(0)
picscount = 1
Else
msgbox "No images found"
End If
'If there is more than one image start timer on drop
If numofpics > 0 Then object.SetTimer 1, 8000

End Sub

Sub Object_Ontimer1
'If count is higher than number of pics then reset count
If picscount > numofpics Then picscount = 0
'Set picture
Object.Picture = grpofpics(picscount)
'Add to count
picscount = picscount + 1
End Sub

Sub Object_OnStateChange(state)
If state="Command executed" Then
System.SetWallpaper Object.Directory & "vista-1.bmp", 3
End If
End Sub

beginners

Locked Post

Advanced Search

Watch this post

Do not email me updates for this post Email me updates for this post

Successfully updated karma reason!

Vad_M

Join Date 08/2004

+117

I tested your code. It works good. But if you want optimize it try to use this:

Dim mypics(),num

Sub Object_OnScriptEnter
ReDim Preserve mypics(0)
mypics(0) = ""
num = 0
End Sub

Sub Object_OnDropFiles(files)
Call MakeStream(files,0)
End Sub

Sub MakeStream(strx,n)
On Error Resume Next
ReDim mypics(0)'<== clear the array
mypics(0) = ""
num = 0
myitems = split(strx,"|")
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each item In myitems
If objFSO.FolderExists(item) Then
Set objFolder = objFSO.GetFolder(item)
Call AddFiles_Ex(objFSO,item,n) '<== if item is folder send it to the other Sub
Set objFolder = nothing
ElseIf objFSO.FileExists(item) Then
ext = LCase(objFSO.GetExtensionName(item))
If IsImage(ext) Then '<== checking for file extension
Set objFile = objFSO.GetFile(item)
ReDim Preserve mypics(n) '<== if item is file add it into array
mypics(n) = objFile.path
n = n + 1
Set objFile = nothing
End If
End If
Next
Set objFSO = nothing
If len(mypics(num)) > 5 Then
Object.Picture = mypics(num) '<== apply the first picture
object.SetTimer 1, 8000
Else
msgbox "No images found"
End If
If err.number > 0 Then err.clear
End Sub

'< Example of usage the Recursive method to get files>

Sub AddFiles_Ex(objFSO,fp,n) '<== This code will allow you to get Files not only from Folders
On Error Resume Next 'bat from each SubFolders in this Folder.
Set objFOL = objFSO.GetFolder(fp)
Set objFIL = objFOL.Files
If objFIL.count > 0 Then
For Each item In objFIL
ext = LCase(objFSO.GetExtensionName(item.path))
If IsImage(ext) Then
ReDim Preserve mypics(n)
mypics(n) = item.path
n = n + 1
End If
Next
End If
Set objSUB = objFOL.SubFolders
If objSUB.count > 0 Then
For Each subitem In objSUB
Call AddFiles_Ex(objFSO,subitem.path,n)
Next
End If
Set objSUB = nothing
Set objFIL = nothing
Set objFOL = nothing
End Sub

Function IsImage(ext)
Select Case ext
Case "bmp","png","ico","jpg","tga" IsImage = True
Case Else IsImage = False
End Select
End Function

Sub Object_Ontimer1
If num > UBound(mypics) Then num = 0 Else num = num + 1
Object.Picture = mypics(num)
End Sub

Sub Object_OnStateChange(state)
If state="Command executed" Then
System.SetWallpaper Object.Directory & "vista-1.bmp", 3
End If
End Sub

Sub Object_OnScriptExit
Erase mypics
object.KillTimer 1
End Sub

Best Regards.

Successfully updated karma reason!