?
Solved

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

Posted on 2014-01-30
10
Medium Priority
?
324 Views
Last Modified: 2014-03-16
VB script to download 5 background images to local machine on logoff and cycle through each image each time the computer boots.

I have inherited a script which apparently currently works, I need to basically duplicate the existing setup with 5 different images, for a different OU.

I have attached the reg file and vb script as it stands.

I am currently getting an error on line 155 permission denied, it was pointing to c:\windows\company
I've tried
%homepath%
and
c:\temp

Appreciate any help you can.

Thanks

Jamie
reg.txt
vb-script.txt
0
Comment
Question by:llcooljsl1983
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 6
  • 4
10 Comments
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 39827285
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
0
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 39831774
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

Open 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"

Open in new window

0
 

Author Comment

by:llcooljsl1983
ID: 39835886
Thanks for your help, I will test this tomorrow.

Do I still use tilewallpaper, I think that was just used for BGINFO ?
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:llcooljsl1983
ID: 39835911
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
0
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 39837106
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
0
 

Author Comment

by:llcooljsl1983
ID: 39838460
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
0
 

Author Comment

by:llcooljsl1983
ID: 39838478
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.
0
 

Accepted Solution

by:
llcooljsl1983 earned 0 total points
ID: 39838500
OK so our internal scripting wiz has got this working. A copy of the code is below:

' 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 *********
' 1920x1080, 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 = "\\server\dtimages\Travel"
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")


' 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_DesktopMonitor")

    Dim objItem
    For Each objItem in colItems
        width = objItem.ScreenWidth
        'MsgBox width
        height = objItem.ScreenHeight
        'MsgBox height
    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

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

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

' ******** Copy image to PC ********
Dim filePath
Dim fileDestination
filePath = images(randomNum)
'MsgBox filePath

fileDestination = "C:\users\public\company" & fileextension

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

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

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

' Tidy up
Set images = Nothing
Set fso = Nothing
Set ws = Nothing
0
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 39838587
good that it works. using "C:\users\public\ is good for Win7+

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

Open 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....
0
 

Author Closing Comment

by:llcooljsl1983
ID: 39932330
Fixed internally
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This is pretty cool.  The purpose of this VB Script is to help you document where JAR (Java ARchive) files and specifically java class files are located so that you can address issues seen with a client or that you can speak intelligently with a dev…
pc, laptop  monitor connection configurations
Finding and deleting duplicate (picture) files can be a time consuming task. My wife and I, our three kids and their families all share one dilemma: Managing our pictures. Between desktops, laptops, phones, tablets, and cameras; over the last decade…
Want to learn how to record your desktop screen without having to use an outside camera. Click on this video and learn how to use the cool google extension called "Screencastify"! Step 1: Open a new google tab Step 2: Go to the left hand upper corn…
Suggested Courses

719 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question