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
306 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
  • 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
 

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
Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

 

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

Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

Join & Write a Comment

Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
This video discusses moving either the default database or any database to a new volume.
This tutorial demonstrates a quick way of adding group price to multiple Magento products.

758 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

Need Help in Real-Time?

Connect with top rated Experts

21 Experts available now in Live!

Get 1:1 Help Now