Смена обоев рабочего стола

Set WShell = CreateObject("WScript.Shell")
WShell.RegWrite "HKEY_CURRENT_USER\Control Panel\Desktop\Wallpaper","N:\обои\Безымянный.bmp","REG_SZ"
WShell.Run  "%windir%\System32\RUNDLL32.EXE user32.dll, UpdatePerUserSystemParameters", 1, False

Sub SetWallpaper(dirpath, fileName)
    On Error Resume Next
 
    Dim objShellApp, objItem, objFolder, objFile
    Dim colFolderItemVerbs, objFolderItemVerb
 
    Set objShellApp = CreateObject("Shell.Application")
    Set objFolder = objShellApp.Namespace(dirpath)
 
    Set objFile = objFolder.ParseName(fileName)
    Set colFolderItemVerbs = objFile.Verbs
    For Each objFolderItemVerb In colFolderItemVerbs
        If InStr(1, objFolderItemVerb.Name, "фон") Then
          objFolderItemVerb.DoIt
        End If
    Next
End Sub

Dim imagePath
imagePath = "wallpaper.jpg"
 
Set sh = CreateObject("WScript.Shell")
sh.Run "powershell -ex bypass -file ChangeWallpaper.ps1 -imgPath """ & imagePath & """", 0

Dim imagePath
imagePath = "wallpaper.jpg"
 
Set sh = CreateObject("WScript.Shell")
sh.Run "rundll34 user32 SystemParametersInfoA int int:20 int:0 string:""" & imagePath & """ int:2", 0

Sub SetWallpaper(dirpath, fileName)
    On Error Resume Next
 
    Dim objShellApp, objItem, objFolder, objFile
    Dim colFolderItemVerbs, objFolderItemVerb
 
    Set objShellApp = CreateObject("Shell.Application")
    Set objFolder = objShellApp.Namespace(dirpath)
 
    Set objFile = objFolder.ParseName(fileName)
    Set colFolderItemVerbs = objFile.Verbs
    For Each objFolderItemVerb In colFolderItemVerbs
        If InStr(1, objFolderItemVerb.Name, "фон") Then
          objFolderItemVerb.DoIt
        End If
    Next
WScript.Sleep 5000
End Sub
 
SetWallpaper "D:\wallpaper", "wallpaper.jpg"

'——————————————————————————————————————————————————————
' Назначение: Сделать произвольный в заданной папке или
'       указанный графический файл фоном Рабочего стола
'  Авторство: FlasherX (24.02.2017)
'— Путь графического файла или папки с графикой: ——————
Item = "D:\Wallpapers"
'——————————————————————————————————————————————————————
Set oShA = CreateObject("Shell.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Filt = "*.bmp;*.gif;*.jpg;*.jpeg;*.png;*.tif;*.tiff"
If oFSO.FileExists(Item) Then
   If InStr(Filt & ";*", "." & LCase(oFSO._
   GetExtensionName(Item)) & ";*") Then File = Item Else WSH.Quit
ElseIf oFSO.FolderExists(Item) Then
   Set oItems = oShA.NameSpace(Item).Items: oItems.Filter 73920, Filt
   Cnt = oItems.Count: If Cnt = 0 Then WSH.Quit
   Randomize: File = oItems.Item(CLng(Round(Rnd * (Cnt-1), 0))).Path
Else WSH.Quit() End If
On Error Resume Next
Set oShA = oShA.Windows.Item.document.Application
If Not IsObject(oSHA) Then _
Set oShA = GetObject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}").document.Application
On Error GoTo 0: Er = Not IsObject(oSHA)
If Er Then Set oShA = CreateObject("Shell.Application")
oShA.NameSpace(0).ParseName(File).InvokeVerb "setdesktopwallpaper"
If Er Then WSH.Sleep 4000
Set oFSO = Nothing: Set oShA = Nothing