i wrote two little tools which are changing my wallpapers and additionally copy the wonderful Windows 10 Spotlight Backround Images daily to my current wallpaper folder. You just need to add these two little programs to the task scheduler and decide yourself how often they are executed.
Code: Select all
;Wallpaper Changer
#WPSTYLE_CENTER = 0
#WPSTYLE_TILE = 1
#WPSTYLE_STRETCH = 2
#WPSTYLE_MAX = 3
#AD_APPLY_SAVE = 1
#AD_APPLY_HTMLGEN = 2
#AD_APPLY_REFRESH = 4
#AD_APPLY_FORCE = 8
#AD_APPLY_BUFFERED_REFRESH = 10
#AD_APPLY_COMPLETEREFRESH = 20
#AD_APPLY_DYNAMICREFRESH = 20
#AD_APPLY_ALL = #AD_APPLY_SAVE | #AD_APPLY_HTMLGEN | #AD_APPLY_REFRESH
Structure myWALLPAPEROPT
dwSize.l
dwStyle.l
EndStructure
Global wallpaperOptions.myWALLPAPEROPT
Global deskObj.IActiveDesktop
Procedure.s GetWallpaper()
CoInitialize_(0)
wbuf=AllocateMemory(1000) ;wide char
mbuf=AllocateMemory(1000) ;multy byte
CoCreateInstance_(?CLSID_ActiveDesktop,0,1,?IID_IActiveDesktop,@pobj.IActiveDesktop)
pobj\GetWallpaper(wbuf,1000,0)
pobj\release()
WideCharToMultiByte_(#CP_ACP,0,wbuf,-1,mbuf,1000,#Null,#Null)
ProcedureReturn PeekS(mbuf,1000,#PB_UTF8)
CoUninitialize_()
FreeMemory(0)
FreeMemory(1)
;CLSID_ActiveDesktop="{75048700-EF1F-11D0-9888-006097DEACF9}"
;IID_IActiveDesktop="{F490EB00-1240-11D1-9888006097DEACF9}"
EndProcedure
Procedure SetWallpaper(myWallpaper$, Style)
CoInitialize_(0)
If CoCreateInstance_(?CLSID_ActiveDesktop,0,1,?IID_IActiveDesktop,@deskObj.IActiveDesktop) <> #S_OK
MessageRequester("Error", "Could not create object")
End
EndIf
wallpaperOptions\dwSize = SizeOf(myWALLPAPEROPT)
wallpaperOptions\dwStyle = Style
;... allocate for wStr filename
*filenameWide = AllocateMemory(Len(myWallpaper$)*2+2)
PokeS(*filenameWide, myWallpaper$, -1, #PB_Unicode)
If deskObj\SetWallpaperOptions(@wallpaperOptions, 0) = #S_OK
If deskObj\SetWallpaper(*filenameWide, 0) = #S_OK
If deskObj\ApplyChanges(#AD_APPLY_ALL) <> #S_OK
MessageRequester("Error", "Unable to apply changes to Wallpaper.")
EndIf
EndIf
EndIf
FreeMemory(*filenameWide)
If deskObj
deskObj\Release()
EndIf
CoUninitialize_()
ProcedureReturn 0
EndProcedure
If Not OSVersion() = #PB_OS_Windows_10 : MessageRequester("ChangeWallpaper", "This tool requires Windows 10!") : End : EndIf
oldwallpaper.s = GetWallpaper() : Debug oldwallpaper
If Not ReadFile(0, oldwallpaper) And IsFile(0) : MessageRequester("ChangeWallpaper", "Could not retrieve current wallpaper!") : End : EndIf : CloseFile(0)
wallpaper.s = Space(#MAX_PATH)
Directory.s = GetPathPart(oldwallpaper)
NewList Wallpapers.s()
If ExamineDirectory(0, Directory, "*.*")
While NextDirectoryEntry(0)
If DirectoryEntryType(0) = #PB_DirectoryEntry_File
Ext.s = UCase(GetExtensionPart(DirectoryEntryName(0)))
Select Ext
Case "JPG", "JPEG", "PNG", "BMP"
If Not DirectoryEntryName(0) = GetFilePart(oldwallpaper)
countwallpapers + 1 : AddElement(Wallpapers()) : Wallpapers() = GetFilePart(DirectoryEntryName(0))
EndIf
EndSelect
EndIf
Wend
FinishDirectory(0)
EndIf
If Not countwallpapers = 0
newwallpaper_id = Random(countwallpapers, 1)
SelectElement(Wallpapers(), newwallpaper_id) : newwallpaper.s = Wallpapers() : Debug newwallpaper
SetWallpaper(directory+newwallpaper, #WPSTYLE_CENTER)
EndIf
End
DataSection
CLSID_ActiveDesktop:
Data.l $75048700
Data.w $EF1F,$11D0
Data.b $98,$88,$00,$60,$97,$DE,$AC,$F9
IID_IActiveDesktop:
Data.l $F490EB00
Data.w $1240,$11D1
Data.b $98,$88,$00,$60,$97,$DE,$AC,$F9
EndDataSection Code: Select all
; MS SPOTLIGHT Add Images to Wallpapers
#WPSTYLE_CENTER = 0
#WPSTYLE_TILE = 1
#WPSTYLE_STRETCH = 2
#WPSTYLE_MAX = 3
#AD_APPLY_SAVE = 1
#AD_APPLY_HTMLGEN = 2
#AD_APPLY_REFRESH = 4
#AD_APPLY_FORCE = 8
#AD_APPLY_BUFFERED_REFRESH = 10
#AD_APPLY_COMPLETEREFRESH = 20
#AD_APPLY_DYNAMICREFRESH = 20
#AD_APPLY_ALL = #AD_APPLY_SAVE | #AD_APPLY_HTMLGEN | #AD_APPLY_REFRESH
Structure myWALLPAPEROPT
dwSize.l
dwStyle.l
EndStructure
Global wallpaperOptions.myWALLPAPEROPT
Global deskObj.IActiveDesktop
ExamineDesktops() : Global DesktopWidth=DesktopWidth(0), DesktopHeight=DesktopHeight(0)
UseJPEGImageDecoder()
Procedure.s GetWallpaper()
CoInitialize_(0)
wbuf=AllocateMemory(1000) ;wide char
mbuf=AllocateMemory(1000) ;multy byte
CoCreateInstance_(?CLSID_ActiveDesktop,0,1,?IID_IActiveDesktop,@pobj.IActiveDesktop)
pobj\GetWallpaper(wbuf,1000,0)
pobj\release()
WideCharToMultiByte_(#CP_ACP,0,wbuf,-1,mbuf,1000,#Null,#Null)
ProcedureReturn PeekS(mbuf,1000,#PB_UTF8)
CoUninitialize_()
FreeMemory(0)
FreeMemory(1)
;CLSID_ActiveDesktop="{75048700-EF1F-11D0-9888-006097DEACF9}"
;IID_IActiveDesktop="{F490EB00-1240-11D1-9888006097DEACF9}"
EndProcedure
If Not OSVersion() = #PB_OS_Windows_10 : MessageRequester("Spotlighter", "This tool requires Windows 10!") : End : EndIf
SpotLightFolder.s = RemoveString(GetUserDirectory(#PB_Directory_ProgramData), "Roaming\") + "Local\Packages\"
If ExamineDirectory(0, SpotLightFolder.s, "Microsoft.Windows.ContentDeliveryManager_*")
While NextDirectoryEntry(0)
If DirectoryEntryType(0) = #PB_DirectoryEntry_Directory
SpotLightFolder.s = SpotLightFolder.s + DirectoryEntryName(0) + "\LocalState\Assets\"
Else
MessageRequester("SpotLighter", "Error Finding Asset Folder") : End
EndIf
Wend
FinishDirectory(0)
Else
MessageRequester("SpotLight Tool", "Error Finding Asset Folder") : End
EndIf
Debug SpotLightFolder
CurrentWallpaper.s = GetWallpaper() : Debug CurrentWallpaper
DirCurrentWallpaper.s = GetPathPart(CurrentWallPaper)
If CurrentWallpaper = "" : MessageRequester("SpotLighter", "Error Finding Current Wallpaper") : End : EndIf
If ExamineDirectory(0, SpotLightFolder, "*.*")
While NextDirectoryEntry(0)
If DirectoryEntryType(0) = #PB_DirectoryEntry_File
image.s = DirectoryEntryName(0) ;Debug SpotlightFolder+ image
If LoadImage(0, SpotlightFolder+image)
If ImageHeight(0) = DesktopHeight And ImageWidth(0) = DesktopWidth
If Not FileSize(DirCurrentWallpaper+image+".jpg") > 0
Debug "Copy"
CopyFile(SpotlightFolder+image, DirCurrentWallpaper+image+".jpg")
EndIf
EndIf
FreeImage(0)
EndIf
EndIf
Wend
FinishDirectory(0)
EndIf
End
DataSection
CLSID_ActiveDesktop:
Data.l $75048700
Data.w $EF1F,$11D0
Data.b $98,$88,$00,$60,$97,$DE,$AC,$F9
IID_IActiveDesktop:
Data.l $F490EB00
Data.w $1240,$11D1
Data.b $98,$88,$00,$60,$97,$DE,$AC,$F9
EndDataSection Greetings
A.D.