VB script to download 5 background images to local machine on logoff and cycle through each image each time the computer boots

scripts running during logon / logoff run as the user; who cant access the Windows folder by default anymore.

I have a similar script that sets screensave & startup image but it runs as a Startup script so that it runs as System user, with full permissions so it can write to the windows \ background folder. but you need to ensure that the images folder is available under \\domain\NetLogon as the system user cant access other network folders.

with GPO (which i thick you are using to trigger the logon/logoff) you can also set the screen saver rather than using reg script. though i guess it may work

I assume you want to set the desktop background to this image ?
create a c:\temp folder & copy image there.

Screen.exe must be an app deployed somehow as well. Not sure why the parameter is .BGI

I moded the script but it still fails to write to the HKLM key UNLESS run as administrator.

so ignore the last part and  modify the REG file to point to C:\TEMP\randombackg.jpg which is the name i use for the destination image.  Then the script will handle the copy of random image to the destination image as the regfile only needs to be run once.

' @Copyright 
' @Author

' Wallpaper logon script to randomly select an appropriate scaled jpg from those listed within the wallpaper folder located
' within the netlogon share.  This image is then copied to the users c drive before being specified as the desktop background
' via group policy.

' ******** Pick correct images based on Desktop Size, or nearest match based on aspect ratio *********
' 1280x720                                                              = 1.7777 to 1
' 1920x1200, 1680x1050, 1440x900, 1280x800                              = 1.6000 to 1
' 1600x1024                                                             = 1.5625 to 1
' 1920x1400                                                             = 1.3714 to 1
' 2048x1536, 1600x1200, 1280x960, 1152x864, 1024x768, 800x600, 640x480  = 1.3333 to 1
' 1280x1024                                                             = 1.2500 to 1

Option Explicit

' determines wallpaper location on fileserver and sets imagepath to end with \
dim imagesPath
imagesPath = "\\MYSERVER\netlogon\backgrounds\"
dim fileextension
fileextension = ".jpg" ' to prevent thumbs.db being chosen
If WScript.Arguments.Count > 0 Then ImagesPath = WScript.Arguments(0)

If Mid(imagesPath, Len(imagesPath)) <> "\" Then imagesPath = imagesPath & "\"

Dim fso
Dim ws
Dim wallfile
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = WScript.CreateObject("WScript.Shell")

' ******** Start Getting List of images ********
Dim images
Set images = FindImagesForResolution(imagesPath)

Randomize Timer
Dim randomNum
randomNum = CInt( ( images.Count - 1 ) * Rnd )

' ******** Copy image to PC ********
Dim filePath, imgPath
Dim fileDestination
imgPath= images(randomNum)
'MsgBox filePath
filepath = "C:\temp\"   'location to save image. Must have write permissions.  NOT c:\, c:\windows
fileDestination = filepath & "randombackg.jpg"  'std name for image

if not fso.FolderExists(filepath) then fso.CreateFolder(filepath)   'make path if not exist

If fso.FileExists(fileDestination) Then fso.DeleteFile fileDestination, True

' Make sure we've found something
If Len(filePath) > 0 Then
    'copy file to dest.
    fso.GetFile(imgPath).Copy(fileDestination)
    set wallfile = fso.getfile(filedestination)
    wallfile.attributes = wallfile.attributes + 1
    wallfile.attributes = wallfile.attributes + 2
End If 


'now update the registry
dim regKey, regVal

regKey = "HKCU\Control Panel\Desktop\TileWallpaper"
regVal = "1"
ws.regWrite regKey ,"1", "REG_SZ"


'###### likely ot fail unless run as Administrator
regKey = "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\Company Details"
'regKey = "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\RTHDVCPL"
on error resume next 
regVal = "c:\windows\Screen.exe " & fileDestination & " /timer:0"
ws.RegWrite regKey , regVal , "REG_SZ"



' Tidy up
Set images = Nothing
Set fso = Nothing
Set ws = Nothing

wscript.quit


' determines local width and height resolution of current display
' ******** Start Getting Desktop Res Info ******** 

Sub GetResolution(ByRef width, ByRef height)
    Dim strComputer
    strComputer = "."

    Dim objWMIService
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

    Dim colItems
    Set colItems = objWMIService.ExecQuery("Select * From Win32_DisplayConfiguration")

    Dim objItem
    For Each objItem in colItems
        width = objItem.PelsWidth
        height = objItem.PelsHeight
    Next
    
    Set colItems = Nothing
    Set objWMIService = Nothing
End Sub

Function GetKey(ByVal wdth, ByVal height)
    GetKey = CStr(wdth) & "x" & CStr(height) & ":" & CStr(wdth / height) 
End Function

Function GetFolderPathForCorrectImageResolution(imagesPath)
    'Get the folder containing the images
    Dim wdth
    Dim height
    Call GetResolution(wdth, height)
    Dim resolutionKey
    resolutionKey = GetKey(wdth, height)
    Dim ImageFolder
    Set ImageFolder = fso.GetFolder(imagesPath)

    Dim folders
    Set folders = CreateObject("Scripting.Dictionary")
    Dim folderKey

    Dim imageSubFolder
    For Each imageSubFolder In ImageFolder.subFolders
       If InStr(imageSubFolder.Name, "x") > 0 Then
           Dim folderwidth
           Dim folderheight
           folderwidth = Mid(imageSubFolder.Name, 1, InStr(imageSubFolder.Name, "x") - 1)
           folderheight = Mid(imageSubFolder.Name, InStr(imageSubFolder.Name, "x") + 1)
           folderKey =  GetKey(folderwidth, folderheight)
           folders.Add folderKey, imageSubFolder.Name
       End If
    Next

    ' we need to loop through the list until we find the nearest match less than the current res
    Dim matchKey
    matchKey = ""
    Dim loopKey
    For Each loopKey In folders.Keys
        If loopKey > resolutionKey Then Exit For
        If AspectRatioMatches(loopKey, resolutionKey) Then
           matchKey = loopKey
        End If
    Next
    If matchKey = "" Then ' we failed to find an exact or aspect ratio match, default the image
        matchKey = folderKey ' the last one we found (the biggest)
    End If
    'MsgBox matchKey
    GetFolderPathForCorrectImageResolution = folders(matchKey)
End Function

Function AspectRatioMatches(keyToCheck, keyToCheckAgainst)
    Dim aspectToCheck
    Dim aspectToCheckAgainst
    aspectToCheck = Mid(CStr(keyToCheck), InStr(CStr(keyToCheck), ":")+1, Len(CStr(keyToCheck)) - InStr(CStr(keyToCheck), ":"))
    aspectToCheckAgainst = Mid(CStr(keyToCheckAgainst), InStr(CStr(keyToCheckAgainst), ":")+1, Len(CStr(keyToCheckAgainst)) - InStr(CStr(keyToCheckAgainst), ":"))
    'MsgBox aspectToCheck
    AspectRatioMatches = CBool(aspectToCheck = aspectToCheckAgainst)
End Function

Function FindImagesForResolution(imagesPath)
    Dim ImageFolder
    Dim FolderPath
    FolderPath = GetFolderPathForCorrectImageResolution(imagesPath)
    'MsgBox imagesPath & FolderPath
    Set ImageFolder = fso.GetFolder(imagesPath + FolderPath)

    Dim i
    i = 0
    Dim foundImageFiles
    Set foundImageFiles = CreateObject("Scripting.Dictionary")
    Dim foundFileName
    For Each foundFileName In imageFolder.Files
        if InStr(foundFileName, fileextension) Then
            foundImageFiles.Add i, foundFileName
            i = i + 1
        end if
    Next
    
    Set FindImagesForResolution = foundImageFiles
End Function

Select allOpen in new window

REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run]
"Company Details"="c:\\windows\\Screen.exe c:\\temp\\randombackg.jpg /timer:0"

[HKEY_CURRENT_USER\Control Panel\Desktop]
"TileWallpaper"="1"

Select allOpen in new window

Thanks for your help, I will test this tomorrow.

Do I still use tilewallpaper, I think that was just used for BGINFO ?

If it's easier, we can use a different location like %HOMEPATH% that each user would have access to for the image, we can then use GPO to set the background.

The issue I can see though is that each wallpaper has a different filename, and it cycles through 14 images now, how would we get it to choose the right image as this will change each time.

Thanks

My script copies the random image to the same filename each time so that the background settings never have to change.
I would prefer that the background image be on c drive rather than a network location

OK I have made some good progress, I created a GPO which copies the standard background to c:\users\public\background.jpg.

The GPO also selects this location for the background.

I filtered the policy via WMI to just Windows 7 users.

Everything is working and images cycle each logoff and logon process.

The only issue I have now is that the images selected are always 1024x768 even though the screen resolution is Full HD 1920x1080.

Any ideas?

Thanks

Just found this:

The Win32_displayConfiguration WMI class no longer works beginning with Windows Vista. This is detailed on MSDN msdn.microsoft.com/.../aa394137(v=vs.85).aspx Instead, use the Win32_VideoController.

good that it works. using "C:\users\public\ is good for Win7+

does

' Refresh the screen
Ws.SendKeys "{F5}"

Select allOpen in new window

actually do much as send keys can cause issues if the window focus changes.

its probably just me but i prefer to keep all the functions at the end of th script so that program flow is obvious and not hidden between function definitions....

Fixed internally