Slideshow request please help

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
1,506 views 4 replies
Reply #1 Top
Reply #2 Top
Hey, Koradin. Add the code below to the script and it should work. Credit goes to Garibaldi99 and Quentin94.



Sub object_Onlbuttonup(x,y,d)
If Not d Then
jpgFName= grpofpics(picscount-1)
LSetWallpaper(jpgFName)
End If
End Sub

Sub LSetWallpaper(jpgFName)
Set fso = CreateObject ("Scripting.FileSystemObject")
Set windowspath = fso.GetSpecialFolder(2)
winbmp = windowspath & "\wallpaperfile.bmp"
winjpg = windowspath & "\wallpaperfile.jpg"
If fso.FileExists(winbmp) Then
fso.DeleteFile winbmp
End If
If fso.FileExists(winjpg) Then
fso.DeleteFile winjpg
End If
fso.CopyFile jpgFName,winjpg,True
System.SetWallpaper winjpg,3
End Sub


Reply #3 Top
sViz,
Thanks so much for your responce. The code does work but has some issues. It doesn't really seem to change the wallpaper as it does just paste over it. Any time a window is opened and then closed the wallpaper where that window was open is gone and just the background color is there. Thanks again!
Reply #4 Top
What image type are you using? Bitmaps and Jpegs will work but PNGs and other image types will not. They will make the wall blank.