Source code for wallpapr.vbs

```
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
```
```
 
```