Option Explicit Dim arrBitmaps Dim blnDebug, blnError, blnFileAttrFilter, blnFileSizeFilter, blnFileTimeFilter, blnRecursive Dim i, intAttr, intDelay, intParams, intRandom, intSize, lngDate, lngToday Dim colMatches, objFolder, objFSO, objRE, StdOut, wshShell Dim strDate, strError, strFileNameFilter, strFileSizeFilter, strFileTimeFilter Dim strFolder, strMsg, strRefresh, strRegVal, strScriptEnv, strWallpaper ' Create objects Set objFSO = CreateObject( "Scripting.FileSystemObject" ) Set wshShell = CreateObject( "WScript.Shell" ) ' Defaults and initial values blnDebug = False blnError = False blnFileAttrFilter = False blnFileSizeFilter = False blnFileTimeFilter = False blnRecursive = False intAttr = 0 intDelay = 0 intParams = 0 strFileNameFilter = "*.bmp" strFolder = wshShell.ExpandEnvironmentStrings( "%windir%" ) If InStr( LCase( WScript.FullName ), "\cscript.exe" ) > 0 Then strScriptEnv = "CScript" Set StdOut = WScript.StdOut Else strScriptEnv = "WScript" End If ' Check Windows version If wshShell.ExpandEnvironmentStrings( "%OS%" ) <> "Windows_NT" Then Syntax "This script can only run in Windows 2000 or later" End If ' Parse and check command line arguments ' Only 1 unnamed argument allowed If WScript.Arguments.Unnamed.Count > 1 Then Syntax "Too many unnamed command line arguments" End If ' Check if the one unnamed argument is an existing file or folder If WScript.Arguments.Unnamed.Count = 1 Then If objFSO.FolderExists( WScript.Arguments.Unnamed(0) ) Then ' argument is a valid folder strFolder = WScript.Arguments.Unnamed(0) ElseIf objFSO.FileExists( WScript.Arguments.Unnamed(0) ) Then ' argument is a valid file name strWallpaper = WScript.Arguments.Unnamed(0) ElseIf objFSO.FileExists( objFSO.BuildPath( strFolder, WScript.Arguments.Unnamed(0) ) ) Then ' argument is an existing file in the default folder strWallpaper = objFSO.BuildPath( strFolder, WScript.Arguments.Unnamed(0) ) Else ' invalid argument Syntax "Can't find a file nor a folder named " & WScript.Arguments.Unnamed(0) End If End If ' /? means show help If WScript.Arguments.Named.Exists( "?" ) Then Syntax "" ' /DEBUG means debugging, but only when running in CSCRIPT.EXE If WScript.Arguments.Named.Exists( "DEBUG" ) Then intParams = intParams + 1 If strScriptEnv = "CScript" Then blnDebug = True Else WScript.Echo "Use /DEBUG switch only when running in CSCRIPT.EXE" End If End If ' /A switch means filter based on file attributes A, C, H, R and/or S If WScript.Arguments.Named.Exists( "A" ) Then Set objRE = New RegExp objRE.Global = False objRE.IgnoreCase = True objRE.Pattern = "^[achrs]{1,5}$" Set colMatches = objRE.Execute( WScript.Arguments.Named( "A" ) ) If colMatches.Count <> 1 Then strError = "Missing or invalid attributes for the /A switch." If strScriptEnv = "CScript" Then strError = strError & vbCrLf & " " strError = strError & " Valid attributes are A, C, H, R and S, concatenated in any combination." Syntax strError End If Set colMatches = Nothing Set objRE = Nothing intParams = intParams + 1 FilterFileAttributes blnFileAttrFilter = True End If ' /D means wait a number of seconds If WScript.Arguments.Named.Exists( "D" ) Then intDelay = WScript.Arguments.Named( "D" ) If intDelay = "" Then Syntax "The /D switch was used, but no delay was specified" End If If Not IsNumeric( intDelay ) Then Syntax "Please specify a number of seconds with the /D switch" End If If intDelay < 1 Or intDelay > 65536 Then strError = "An invalid number of seconds was specified for the /D switch." If strScriptEnv = "CScript" Then strError = strError & vbCrLf & " " strError = strError & " The delay may range from 1 to 65536 seconds." Syntax strError End If intParams = intParams + 1 End If ' /F means filter based on filespec If WScript.Arguments.Named.Exists( "F" ) Then If WScript.Arguments.Named( "F" ) = "" Then Syntax "The /F switch was used, but no filespec was specified" End If intParams = intParams + 1 strFileNameFilter = WScript.Arguments.Named( "F" ) End If ' /S means recurse subdirectories If WScript.Arguments.Named.Exists( "S" ) Then If WScript.Arguments.Named( "S" ) <> "" Then Syntax "The /S switch does not require a value" End If intParams = intParams + 1 blnRecursive = True End If ' /T means filter based on file date If WScript.Arguments.Named.Exists( "T" ) Then strDate = WScript.Arguments.Named( "T" ) If strDate = "" Then Syntax "The /T switch was used, but no file date was specified" End If If Not IsNumeric( strDate ) Then Syntax "Please specify a date in ""YYYYMMDD"" format with the /T switch" End If If Not IsDate( Mid( strDate, 5, 2 ) & "/" & Right( strDate, 2 ) & "/" & Left( strDate, 4 ) ) Then Syntax """" & strDate & """ is not a valid date in ""YYYYMMDD"" format" End If lngDate = CLng( strDate ) If lngDate < 19800101 Then Syntax "The earliest valid date with the /T switch is ""19800101""" End If lngToday = CLng( Year( Date( ) ) _ & Right( "0" & Month( Date( ) ), 2 ) _ & Right( "0" & Day( Date( ) ), 2 ) ) If lngDate > lngToday + 1 Then Syntax "The latest valid date with the /T switch is """ & strToday & """" End If intParams = intParams + 1 blnFileTimeFilter = True End If ' /Z means filter based on file size If WScript.Arguments.Named.Exists( "Z" ) Then intSize = CLng( WScript.Arguments.Named( "Z" ) ) If intSize = "" Then Syntax "The /Z switch was used, but no file size was specified" End If If Not IsNumeric( intSize ) Then Syntax "Please specify a minimum file size in bytes with the /Z switch" End If If intSize < 1 Then Syntax "Please specify a file size greater than 0 with the /Z switch" End If intParams = intParams + 1 blnFileSizeFilter = True End If If InStr( strWallpaper, "." ) > 0 And ( blnFileSizeFilter _ Or blnFileTimeFilter _ Or blnRecursive _ Or intAttr > 0 _ Or strFileNameFilter <> "*.bmp" ) Then Syntax "Only /D and /DEBUG switches are valid if a bitmap is specified" End If If blnDebug Then strMsg = "Filter Attributes (/A) = " & blnFileAttrFilter & " (" & intAttr & ")" & vbCrLf _ & "Delay (/D) = " & intDelay & vbCrLf _ & "Debug Mode (/DEBUG) = " & blnDebug & vbCrLf _ & "Filter Name (/F) = " & strFileNameFilter & vbCrLf _ & "Recursive (/S) = " & blnRecursive & vbCrLf _ & "Filter Date (/T) = " & blnFileTimeFilter If blnFileTimeFilter Then strMsg = strMsg & " (" & strDate & ")" End If strMsg = strMsg & vbCrLf & "Filter Size (/Z) = " & blnFileSizeFilter If blnFileSizeFilter Then strMsg = strMsg & " (" & intSize & ")" End If strMsg = strMsg & vbCrLf _ & "Bitmap Folder = " & strFolder & vbCrLf _ & "Script Environment = " & strScriptEnv & vbCrLf WScript.Echo strMsg End If ' Check for invalid arguments (switces other than the ones we checked) If intParams < WScript.Arguments.Named.Count Then Syntax "One or more invalid switches were used" End If ' Wait if a delay was specified If intDelay > 0 Then Delay intDelay ' If no bitmap was specified, we still have to choose one If InStr( strWallpaper, "." ) = 0 Then ListFileNames strFolder If blnFileAttrFilter Then FilterAttr If blnFileSizeFilter Then FilterSize If blnFileTimeFilter Then FilterDate strWallpaper = PickOne( ) End If ' Set new wallpaper value in registry strRegVal = "HKEY_CURRENT_USER\Control Panel\Desktop\Wallpaper" If blnDebug Then strMsg = "Writing to registry:" & vbCrLf _ & strRegVal & " = """ & strWallpaper & """" & vbCrLf WScript.Echo strMsg End If wshShell.RegWrite strRegVal, strWallpaper, "REG_SZ" ' Refresh the Desktop strRefresh = "%windir%\System32\RUNDLL32.EXE " _ & "user32.dll,UpdatePerUserSystemParameters" If blnDebug Then strMsg = "Refreshing the Desktop:" & vbCrLf _ & strRefresh & vbCrLf & vbCrLf & "Done" WScript.Echo strMsg End If wshShell.Run strRefresh, 1, True ' Release the objects Set objFSO = Nothing Set StdOut = Nothing Set wshShell = Nothing ' END OF MAIN PROGRAM Sub Delay( numSeconds ) Dim i If Not IsNumeric( numSeconds ) Then Syntax Else For i = CInt( numSeconds ) To 1 Step -1 If blnDebug Then Display "Waiting " & i & " seconds..." End If WScript.Sleep 1000 If blnDebug Then Display String( 40, Chr(8) ) & String( 40, " " ) & String( 40, Chr(8) ) End If Next If blnDebug Then WScript.Echo vbCrLf End If End Sub Sub Display( myString ) If strScriptEnv = "CScript" Then StdOut.Write myString Else WScript.Echo myString End If End Sub Sub DisplayNames( ) Dim objFile, strBitmap, strLastModified WScript.Echo For Each strBitmap In arrBitmaps Set objFile = objFSO.GetFile( strBitmap ) strLastModified = Split( objFile.DateLastModified, " " )(0) WScript.Echo strBitmap & vbTab & strLastModified & vbTab & objFile.Attributes & vbTab & objFile.Size Set objFile = Nothing Next WScript.Echo End Sub Sub FilterAttr( ) If blnDebug Then WScript.Echo "Filtering by file attributes:" End If Dim arrTemp, objFile, strBitmap, intFileAttr Set arrTemp = CreateObject( "System.Collections.ArrayList" ) For Each strBitmap In arrBitmaps Set objFile = objFSO.GetFile( strBitmap ) intFileAttr = CInt( objFile.Attributes ) 'WScript.Echo strBitmap & vbTab & objFile.DateLastModified & vbTab & objFile.Attributes & vbTab & objFile.Size If ( intFileAttr And intAttr ) Then arrTemp.Add( strBitmap ) If blnDebug Then WScript.Echo "Accepted " & strBitmap & vbTab & "(" & objFile.Attributes & ")" End If Else If blnDebug Then WScript.Echo "Rejected " & strBitmap & vbTab & "(" & objFile.Attributes & ")" End If End If Set objFile = Nothing Next arrTemp.TrimToSize Set arrBitmaps = Nothing Set arrBitmaps = arrTemp.Clone( ) Set arrTemp = Nothing If blnDebug Then DisplayNames End Sub Sub FilterDate( ) If blnDebug Then WScript.Echo "Filtering by file date:" End If Dim arrTemp, objFile, strBitmap, strModDate, strLastModified Set arrTemp = CreateObject( "System.Collections.ArrayList" ) For Each strBitmap In arrBitmaps Set objFile = objFSO.GetFile( strBitmap ) strLastModified = FormatDateTime( objFile.DateLastModified, vbShortDate ) strModDate = Year( strLastModified ) _ & Right( "0" & Month( strLastModified ), 2 ) _ & Right( "0" & Day( strLastModified ), 2 ) 'WScript.Echo strBitmap & vbTab & strLastModified & vbTab & strModDate & vbTab & objFile.Attributes & vbTab & objFile.Size If CLng( strModDate ) >= CLng( strDate ) Then arrTemp.Add( strBitmap ) If blnDebug Then WScript.Echo "Accepted " & strBitmap & vbTab & "(" & strModDate & ")" End If Else If blnDebug Then WScript.Echo "Rejected " & strBitmap & vbTab & "(" & strModDate & ")" End If End If Set objFile = Nothing Next arrTemp.TrimToSize Set arrBitmaps = Nothing Set arrBitmaps = arrTemp.Clone( ) Set arrTemp = Nothing If blnDebug Then DisplayNames End Sub Sub FilterFileAttributes( ) Dim strAttr ' Constants for file attributes Const Archive = 32 Const Compressed = 2048 Const Hidden = 2 Const ReadOnly = 1 Const System = 4 ' Valid arguments: any combination of the characters ' A, C, H, R or S; any other character is ignored strAttr = UCase( WScript.Arguments.Named( "A" ) ) If InStr( strAttr, "A" ) > 0 Then intAttr = intAttr + Archive If InStr( strAttr, "C" ) > 0 Then intAttr = intAttr + Compressed If InStr( strAttr, "H" ) > 0 Then intAttr = intAttr + Hidden If InStr( strAttr, "R" ) > 0 Then intAttr = intAttr + ReadOnly If InStr( strAttr, "S" ) > 0 Then intAttr = intAttr + System If blnDebug Then WScript.Echo "Attributes specified: " & strAttr & " => " & intAttr & vbCrLf End If End Sub Sub FilterSize( ) If blnDebug Then WScript.Echo "Filtering by file size:" End If Dim arrTemp, objFile, strBitmap Set arrTemp = CreateObject( "System.Collections.ArrayList" ) For Each strBitmap In arrBitmaps Set objFile = objFSO.GetFile( strBitmap ) 'WScript.Echo strBitmap & vbTab & strLastModified & vbTab & strModDate & vbTab & objFile.Attributes & vbTab & objFile.Size If objFile.Size >= intSize Then arrTemp.Add( strBitmap ) If blnDebug Then WScript.Echo "Accepted " & strBitmap & vbTab & "(" & objFile.Size & ")" End If Else If blnDebug Then WScript.Echo "Rejected " & strBitmap & vbTab & "(" & objFile.Size & ")" End If End If Set objFile = Nothing Next arrTemp.TrimToSize Set arrBitmaps = Nothing Set arrBitmaps = arrTemp.Clone( ) Set arrTemp = Nothing If blnDebug Then DisplayNames End Sub Sub ListFileNames( myFolder ) If blnDebug Then WScript.Echo "Searching through """ & myFolder & """:" End If Dim objFile, objSubFolder Set arrBitmaps = CreateObject( "System.Collections.ArrayList" ) Set objFolder = objFSO.GetFolder( myFolder ) Set objRE = New RegExp objRE.Global = False objRE.IgnoreCase = True strFileNameFilter = Replace( strFileNameFilter, ".", "\." ) strFileNameFilter = Replace( strFileNameFilter, "*", "[-_~#$^&+,a-z0-9]*" ) strFileNameFilter = Replace( strFileNameFilter, "?", "[-_~#$^&+,a-z0-9]" ) If blnDebug Then WScript.Echo "File Name Filter = " & strFileNameFilter End If For Each objFile In objFolder.Files objRE.Pattern = "^" & strFileNameFilter & "$" Set colMatches = objRE.Execute( objFile.Name ) If colMatches.Count = 1 Then arrBitmaps.Add objFile.Path If blnDebug Then WScript.Echo "Adding " & objFile.Path End If Else If blnDebug Then WScript.Echo "Skipping " & objFile.Path End If End If Next Set colMatches = Nothing Set objRE = Nothing If blnRecursive Then If blnDebug Then WScript.Echo "Recursing:" End If For Each objSubFolder In objFolder.Folders ListFileNames( objFolder.Folders.Path ) Next End If If blnDebug Then DisplayNames End Sub Function PickOne( ) Dim objRandom, intRandom Set objRandom = CreateObject( "System.Random" ) intRandom = objRandom.Next_2( 0, arrBitmaps.Count ) If blnDebug Then WScript.Echo "Picking a random number from 0 to " & arrBitmaps.Count & ": " & intRandom & vbCrLf End If PickOne = arrBitmaps( intRandom ) End Function Sub Syntax( errMsg ) Dim StdIn, strMsg If errMsg <> "" And strScriptEnv = "WScript" Then WScript.Echo "Error: " & errMsg strMsg = "WallPaper.vbs, Version 1.01 for Windows 2000 / XP" & vbCrLf _ & "Change Windows' wallpaper" & vbCrLf & vbCrLf _ & "Usage: WALLPAPER.VBS [{ bitmap | folder [options] }] [/D:seconds] [/DEBUG]" & vbCrLf & vbCrLf _ & "Options: [/A:attrs] [/F:filespec] [/S] [/T:yyyymmdd] [/Z:bytes]" & vbCrLf & vbCrLf _ & "Where: bitmap The fully qualified path of the selected bitmap" & vbCrLf _ & " folder Choose random bitmap from this folder (default " & wshShell.ExpandEnvironmentStrings( "%windir%" ) & ")" & vbCrLf _ & " /A:attrs Choose only from bitmaps with these attributes set (ACHRS)" & vbCrLf _ & " /D:seconds Wait number of seconds (useful when running at logon)" & vbCrLf _ & " /DEBUG Verbose display of intermediate values (in CSCRIPT only)" & vbCrLf _ & " /F:filespec Choose only from files matching filespec (default *.BMP)" & vbCrLf _ & " /S Recurse subdirectories" & vbCrLf _ & " /T:yyyymmdd Choose only from files from this date or later" & vbCrLf _ & " /Z:bytes Choose only from files of at least this size" & vbCrLf & vbCrLf _ & "Examples: Change wallpaper to specified bitmap after 120 seconds:" & vbCrLf _ & " WALLPAPER.VBS D:\MyPhotos\Edelweiss.bmp /D:120" & vbCrLf _ & " Randomly pick a read-only bitmap > 64KB from " & wshShell.ExpandEnvironmentStrings( "%windir%" ) & "\IMG*.BMP:" & vbCrLf _ & " WALLPAPER.VBS /A:R /F:""IMG*.BMP"" /Z:65537" & vbCrLf & vbCrLf _ & "Written by Rob van der Woude" & vbCrLf _ & "http://www.robvanderwoude.com" Display strMsg If errMsg <> "" And strScriptEnv = "CScript" Then Display vbCrLf & vbCrLf & vbCrLf & "Error: " & errMsg Set StdOut = Nothing Set wshShell = Nothing Set objFSO = Nothing WScript.Quit 1 End Sub