Slideshow request please help
Monday, March 12, 2007 by Koradin | Discussion: Customization Software
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
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
sViz
Reply #2 Wednesday, March 14, 2007 10:25 PM
Reply #2 Wednesday, March 14, 2007 10:25 PM
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
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
Koradin
Reply #3 Thursday, March 22, 2007 1:36 PM
Reply #3 Thursday, March 22, 2007 1:36 PM
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!
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!
sViz
Reply #4 Friday, March 23, 2007 1:09 AM
Reply #4 Friday, March 23, 2007 1:09 AM
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.
Please login to comment and/or vote for this skin.
Welcome Guest! Please take the time to register with us.
There are many great features available to you once you register, including:
- Richer content, access to many features that are disabled for guests like commenting on the forums and downloading skins.
- Access to a great community, with a massive database of many, many areas of interest.
- Access to contests & subscription offers like exclusive emails.
- It's simple, and FREE!
Reply #1 Tuesday, March 13, 2007 11:51 AM