Rob van der Woude's Scripting Pages
Powered by GeSHi

Source code for wallpapr.vbs

(view source code of wallpapr.vbs as plain text)

  1. Option Explicit
  2.  
  3. Dim arrBitmaps
  4. Dim blnDebug, blnError, blnFileAttrFilter, blnFileSizeFilter, blnFileTimeFilter, blnRecursive
  5. Dim i, intAttr, intDelay, intParams, intRandom, intSize, lngDate, lngToday
  6. Dim colMatches, objFolder, objFSO, objRE, StdOut, wshShell
  7. Dim strDate, strError, strFileNameFilter, strFileSizeFilter, strFileTimeFilter
  8. Dim strFolder, strMsg, strRefresh, strRegVal, strScriptEnv, strWallpaper
  9.  
  10. ' Create objects
  11. Set objFSO   = CreateObject( "Scripting.FileSystemObject" )
  12. Set wshShell = CreateObject( "WScript.Shell" )
  13.  
  14. ' Defaults and initial values
  15. blnDebug          = False
  16. blnError          = False
  17. blnFileAttrFilter = False
  18. blnFileSizeFilter = False
  19. blnFileTimeFilter = False
  20. blnRecursive      = False
  21. intAttr           = 0
  22. intDelay          = 0
  23. intParams         = 0
  24. strFileNameFilter = "*.bmp"
  25. strFolder         = wshShell.ExpandEnvironmentStrings( "%windir%" )
  26. If InStr( LCase( WScript.FullName ), "\cscript.exe" ) > 0 Then
  27. 	strScriptEnv = "CScript"
  28. 	Set StdOut   = WScript.StdOut
  29. Else
  30. 	strScriptEnv = "WScript"
  31. End If
  32.  
  33. ' Check Windows version
  34. If wshShell.ExpandEnvironmentStrings( "%OS%" ) <> "Windows_NT" Then
  35. 	Syntax "This script can only run in Windows 2000 or later"
  36. End If
  37.  
  38. ' Parse and check command line arguments
  39. ' Only 1 unnamed argument allowed
  40. If WScript.Arguments.Unnamed.Count > 1 Then
  41.  	Syntax "Too many unnamed command line arguments"
  42. End If
  43. ' Check if the one unnamed argument is an existing file or folder
  44. If WScript.Arguments.Unnamed.Count = 1 Then
  45. 	If objFSO.FolderExists( WScript.Arguments.Unnamed(0) ) Then
  46. 		' argument is a valid folder
  47. 		strFolder = WScript.Arguments.Unnamed(0)
  48. 	ElseIf objFSO.FileExists( WScript.Arguments.Unnamed(0) ) Then
  49. 		' argument is a valid file name
  50. 		strWallpaper = WScript.Arguments.Unnamed(0)
  51. 	ElseIf objFSO.FileExists( objFSO.BuildPath( strFolder, WScript.Arguments.Unnamed(0) ) ) Then
  52. 		' argument is an existing file in the default folder
  53. 		strWallpaper = objFSO.BuildPath( strFolder, WScript.Arguments.Unnamed(0) )
  54. 	Else
  55. 		' invalid argument
  56. 		Syntax "Can't find a file nor a folder named " & WScript.Arguments.Unnamed(0)
  57. 	End If
  58. End If
  59. ' /? means show help
  60. If WScript.Arguments.Named.Exists( "?" ) Then Syntax ""
  61. ' /DEBUG means debugging, but only when running in CSCRIPT.EXE
  62. If WScript.Arguments.Named.Exists( "DEBUG" ) Then
  63. 	intParams = intParams + 1
  64. 	If strScriptEnv = "CScript" Then
  65. 		blnDebug = True
  66. 	Else
  67. 		WScript.Echo "Use /DEBUG switch only when running in CSCRIPT.EXE"
  68. 	End If
  69. End If
  70. ' /A switch means filter based on file attributes A, C, H, R and/or S
  71. If WScript.Arguments.Named.Exists( "A" ) Then
  72. 	Set objRE        = New RegExp
  73. 	objRE.Global     = False
  74. 	objRE.IgnoreCase = True
  75. 	objRE.Pattern    = "^[achrs]{1,5}$"
  76. 	Set colMatches   = objRE.Execute( WScript.Arguments.Named( "A" ) )
  77. 	If colMatches.Count <> 1 Then
  78. 		strError = "Missing or invalid attributes for the /A switch."
  79. 		If strScriptEnv = "CScript" Then strError = strError & vbCrLf & "      "
  80. 		strError = strError & " Valid attributes are A, C, H, R and S, concatenated in any combination."
  81. 		Syntax strError
  82. 	End If
  83. 	Set colMatches = Nothing
  84. 	Set objRE      = Nothing
  85. 	intParams = intParams + 1
  86. 	FilterFileAttributes
  87. 	blnFileAttrFilter = True
  88. End If
  89. ' /D means wait a number of seconds
  90. If WScript.Arguments.Named.Exists( "D" ) Then
  91. 	intDelay  = WScript.Arguments.Named( "D" )
  92. 	If intDelay = "" Then
  93. 		Syntax "The /D switch was used, but no delay was specified"
  94. 	End If
  95. 	If Not IsNumeric( intDelay ) Then
  96. 		Syntax "Please specify a number of seconds with the /D switch"
  97. 	End If
  98. 	If intDelay < 1 Or intDelay > 65536 Then
  99. 		strError = "An invalid number of seconds was specified for the /D switch."
  100. 		If strScriptEnv = "CScript" Then strError = strError & vbCrLf & "      "
  101. 		strError = strError & " The delay may range from 1 to 65536 seconds."
  102. 		Syntax strError
  103. 	End If
  104. 	intParams = intParams + 1
  105. End If
  106. ' /F means filter based on filespec
  107. If WScript.Arguments.Named.Exists( "F" ) Then
  108. 	If WScript.Arguments.Named( "F" ) = "" Then
  109. 		Syntax "The /F switch was used, but no filespec was specified"
  110. 	End If
  111. 	intParams = intParams + 1
  112. 	strFileNameFilter = WScript.Arguments.Named( "F" )
  113. End If
  114. ' /S means recurse subdirectories
  115. If WScript.Arguments.Named.Exists( "S" ) Then
  116. 	If WScript.Arguments.Named( "S" ) <> "" Then
  117. 		Syntax "The /S switch does not require a value"
  118. 	End If
  119. 	intParams = intParams + 1
  120. 	blnRecursive = True
  121. End If
  122. ' /T means filter based on file date
  123. If WScript.Arguments.Named.Exists( "T" ) Then
  124. 	strDate = WScript.Arguments.Named( "T" )
  125. 	If strDate = "" Then
  126. 		Syntax "The /T switch was used, but no file date was specified"
  127. 	End If
  128. 	If Not IsNumeric( strDate ) Then
  129. 		Syntax "Please specify a date in ""YYYYMMDD"" format with the /T switch"
  130. 	End If
  131. 	If Not IsDate( Mid( strDate, 5, 2 ) & "/" & Right( strDate, 2 ) & "/" & Left( strDate, 4 ) ) Then
  132. 		Syntax """" & strDate & """ is not a valid date in ""YYYYMMDD"" format"
  133. 	End If
  134. 	lngDate = CLng( strDate )
  135. 	If lngDate < 19800101 Then
  136. 		Syntax "The earliest valid date with the /T switch is ""19800101"""
  137. 	End If
  138. 	lngToday = CLng( Year( Date( ) ) _
  139. 	               & Right( "0" & Month( Date( ) ), 2 ) _
  140. 	               & Right( "0" & Day( Date( ) ), 2 ) )
  141. 	If lngDate > lngToday + 1 Then
  142. 		Syntax "The latest valid date with the /T switch is """ & strToday & """"
  143. 	End If
  144. 	intParams = intParams + 1
  145. 	blnFileTimeFilter = True
  146. End If
  147. ' /Z means filter based on file size
  148. If WScript.Arguments.Named.Exists( "Z" ) Then
  149. 	intSize = CLng( WScript.Arguments.Named( "Z" ) )
  150. 	If intSize = "" Then
  151. 		Syntax "The /Z switch was used, but no file size was specified"
  152. 	End If
  153. 	If Not IsNumeric( intSize ) Then
  154. 		Syntax "Please specify a minimum file size in bytes with the /Z switch"
  155. 	End If
  156. 	If intSize < 1 Then
  157. 		Syntax "Please specify a file size greater than 0 with the /Z switch"
  158. 	End If
  159. 	intParams = intParams + 1
  160. 	blnFileSizeFilter = True
  161. End If
  162.  
  163. If InStr( strWallpaper, "." ) > 0 And ( blnFileSizeFilter _
  164.                                      Or blnFileTimeFilter _
  165.                                      Or blnRecursive      _
  166.                                      Or intAttr > 0       _
  167.                                      Or strFileNameFilter <> "*.bmp" ) Then
  168. 	Syntax "Only /D and /DEBUG switches are valid if a bitmap is specified"
  169. End If
  170.  
  171. If blnDebug Then
  172. 	strMsg = "Filter Attributes (/A) = " & blnFileAttrFilter & " (" & intAttr & ")" & vbCrLf _
  173. 	       & "Delay             (/D) = " & intDelay          & vbCrLf _
  174. 	       & "Debug Mode    (/DEBUG) = " & blnDebug          & vbCrLf _
  175. 	       & "Filter Name       (/F) = " & strFileNameFilter & vbCrLf _
  176. 	       & "Recursive         (/S) = " & blnRecursive      & vbCrLf _
  177. 	       & "Filter Date       (/T) = " & blnFileTimeFilter
  178. 	If blnFileTimeFilter Then
  179. 		strMsg = strMsg & " (" & strDate & ")"
  180. 	End If
  181. 	strMsg = strMsg & vbCrLf & "Filter Size       (/Z) = " & blnFileSizeFilter 
  182. 	If blnFileSizeFilter Then
  183. 		strMsg = strMsg & " (" & intSize & ")"
  184. 	End If
  185. 	strMsg = strMsg & vbCrLf _
  186. 	       & "Bitmap Folder          = " & strFolder         & vbCrLf _
  187. 	       & "Script Environment     = " & strScriptEnv      & vbCrLf
  188. 	WScript.Echo strMsg
  189. End If
  190.  
  191. ' Check for invalid arguments (switces other than the ones we checked)
  192. If intParams < WScript.Arguments.Named.Count Then
  193. 	Syntax "One or more invalid switches were used"
  194. End If
  195.  
  196. ' Wait if a delay was specified
  197. If intDelay > 0 Then Delay intDelay
  198.  
  199. ' If no bitmap was specified, we still have to choose one
  200. If InStr( strWallpaper, "." ) = 0 Then
  201. 	ListFileNames strFolder
  202. 	If blnFileAttrFilter Then FilterAttr
  203. 	If blnFileSizeFilter Then FilterSize
  204. 	If blnFileTimeFilter Then FilterDate
  205. 	strWallpaper = PickOne( )
  206. End If
  207.  
  208. ' Set new wallpaper value in registry
  209. strRegVal  = "HKEY_CURRENT_USER\Control Panel\Desktop\Wallpaper"
  210. If blnDebug Then
  211. 	strMsg = "Writing to registry:" & vbCrLf _
  212. 	       & strRegVal & " = """ & strWallpaper & """" & vbCrLf
  213. 	WScript.Echo strMsg
  214. End If
  215. wshShell.RegWrite strRegVal, strWallpaper, "REG_SZ"
  216.  
  217. ' Refresh the Desktop
  218. strRefresh = "%windir%\System32\RUNDLL32.EXE " _
  219.            & "user32.dll,UpdatePerUserSystemParameters"
  220. If blnDebug Then
  221. 	strMsg = "Refreshing the Desktop:" & vbCrLf _
  222. 	       & strRefresh & vbCrLf & vbCrLf & "Done"
  223. 	WScript.Echo strMsg
  224. End If
  225. wshShell.Run strRefresh, 1, True
  226.  
  227. ' Release the objects
  228. Set objFSO   = Nothing
  229. Set StdOut   = Nothing
  230. Set wshShell = Nothing
  231.  
  232.  
  233. ' END OF MAIN PROGRAM
  234.  
  235.  
  236. Sub Delay( numSeconds )
  237. 	Dim i
  238. 	If Not IsNumeric( numSeconds ) Then
  239. 		Syntax
  240. 	Else
  241. 		For i = CInt( numSeconds ) To 1 Step -1
  242. 			If blnDebug Then
  243. 				Display "Waiting " & i & " seconds..."
  244. 			End If
  245. 			WScript.Sleep 1000
  246. 			If blnDebug Then
  247. 				Display String( 40, Chr(8) ) & String( 40, " " ) & String( 40, Chr(8) )
  248. 			End If
  249. 		Next
  250. 		If blnDebug Then WScript.Echo vbCrLf
  251. 	End If
  252. End Sub
  253.  
  254.  
  255. Sub Display( myString )
  256. 	If strScriptEnv = "CScript" Then
  257. 		StdOut.Write myString
  258. 	Else
  259. 		WScript.Echo myString
  260. 	End If
  261. End Sub
  262.  
  263.  
  264. Sub DisplayNames( )
  265. 	Dim objFile, strBitmap, strLastModified
  266. 	WScript.Echo
  267. 	For Each strBitmap In arrBitmaps
  268. 		Set objFile = objFSO.GetFile( strBitmap )
  269. 		strLastModified = Split( objFile.DateLastModified, " " )(0)
  270. 		WScript.Echo strBitmap & vbTab & strLastModified & vbTab & objFile.Attributes & vbTab & objFile.Size
  271. 		Set objFile = Nothing
  272. 	Next
  273. 	WScript.Echo
  274. End Sub
  275.  
  276.  
  277. Sub FilterAttr( )
  278. 	If blnDebug Then
  279. 		WScript.Echo "Filtering by file attributes:"
  280. 	End If
  281. 	Dim arrTemp, objFile, strBitmap, intFileAttr
  282. 	Set arrTemp = CreateObject( "System.Collections.ArrayList" )
  283. 	For Each strBitmap In arrBitmaps
  284. 		Set objFile = objFSO.GetFile( strBitmap )
  285. 		intFileAttr = CInt( objFile.Attributes )
  286. 		'WScript.Echo strBitmap & vbTab & objFile.DateLastModified & vbTab & objFile.Attributes & vbTab & objFile.Size
  287. 		If ( intFileAttr And intAttr ) Then
  288. 			arrTemp.Add( strBitmap )
  289. 			If blnDebug Then
  290. 				WScript.Echo "Accepted " & strBitmap & vbTab & "(" & objFile.Attributes & ")"
  291. 			End If
  292. 		Else
  293. 			If blnDebug Then
  294. 				WScript.Echo "Rejected " & strBitmap & vbTab & "(" & objFile.Attributes & ")"
  295. 			End If
  296. 		End If
  297. 		Set objFile = Nothing
  298. 	Next
  299. 	arrTemp.TrimToSize
  300. 	Set arrBitmaps = Nothing
  301. 	Set arrBitmaps = arrTemp.Clone( )
  302. 	Set arrTemp    = Nothing
  303. 	If blnDebug Then DisplayNames
  304. End Sub
  305.  
  306.  
  307. Sub FilterDate( )
  308. 	If blnDebug Then
  309. 		WScript.Echo "Filtering by file date:"
  310. 	End If
  311. 	Dim arrTemp, objFile, strBitmap, strModDate, strLastModified
  312. 	Set arrTemp = CreateObject( "System.Collections.ArrayList" )
  313. 	For Each strBitmap In arrBitmaps
  314. 		Set objFile = objFSO.GetFile( strBitmap )
  315. 		strLastModified = FormatDateTime( objFile.DateLastModified, vbShortDate )
  316. 		strModDate = Year( strLastModified ) _
  317. 		           & Right( "0" & Month( strLastModified ), 2 ) _
  318. 		           & Right( "0" & Day( strLastModified ), 2 )
  319. 		'WScript.Echo strBitmap & vbTab & strLastModified & vbTab & strModDate & vbTab & objFile.Attributes & vbTab & objFile.Size
  320. 		If CLng( strModDate ) >= CLng( strDate ) Then
  321. 			arrTemp.Add( strBitmap )
  322. 			If blnDebug Then
  323. 				WScript.Echo "Accepted " & strBitmap & vbTab & "(" & strModDate & ")"
  324. 			End If
  325. 		Else
  326. 			If blnDebug Then
  327. 				WScript.Echo "Rejected " & strBitmap & vbTab & "(" & strModDate & ")"
  328. 			End If
  329. 		End If
  330. 		Set objFile = Nothing
  331. 	Next
  332. 	arrTemp.TrimToSize
  333. 	Set arrBitmaps = Nothing
  334. 	Set arrBitmaps = arrTemp.Clone( )
  335. 	Set arrTemp    = Nothing
  336. 	If blnDebug Then DisplayNames
  337. End Sub
  338.  
  339.  
  340. Sub FilterFileAttributes( )
  341. 	Dim strAttr
  342. 	' Constants for file attributes
  343. 	Const Archive    =   32
  344. 	Const Compressed = 2048
  345. 	Const Hidden     =    2
  346. 	Const ReadOnly   =    1
  347. 	Const System     =    4
  348. 	' Valid arguments: any combination of the characters
  349. 	' A, C, H, R or S; any other character is ignored
  350. 	strAttr = UCase( WScript.Arguments.Named( "A" ) )
  351. 	If InStr( strAttr, "A" ) > 0 Then intAttr = intAttr + Archive
  352. 	If InStr( strAttr, "C" ) > 0 Then intAttr = intAttr + Compressed
  353. 	If InStr( strAttr, "H" ) > 0 Then intAttr = intAttr + Hidden
  354. 	If InStr( strAttr, "R" ) > 0 Then intAttr = intAttr + ReadOnly
  355. 	If InStr( strAttr, "S" ) > 0 Then intAttr = intAttr + System
  356. 	If blnDebug Then
  357. 		WScript.Echo "Attributes specified: " & strAttr & " => " & intAttr & vbCrLf
  358. 	End If
  359. End Sub
  360.  
  361.  
  362. Sub FilterSize( )
  363. 	If blnDebug Then
  364. 		WScript.Echo "Filtering by file size:"
  365. 	End If
  366. 	Dim arrTemp, objFile, strBitmap
  367. 	Set arrTemp = CreateObject( "System.Collections.ArrayList" )
  368. 	For Each strBitmap In arrBitmaps
  369. 		Set objFile = objFSO.GetFile( strBitmap )
  370. 		'WScript.Echo strBitmap & vbTab & strLastModified & vbTab & strModDate & vbTab & objFile.Attributes & vbTab & objFile.Size
  371. 		If objFile.Size >= intSize Then
  372. 			arrTemp.Add( strBitmap )
  373. 			If blnDebug Then
  374. 				WScript.Echo "Accepted " & strBitmap & vbTab & "(" & objFile.Size & ")"
  375. 			End If
  376. 		Else
  377. 			If blnDebug Then
  378. 				WScript.Echo "Rejected " & strBitmap & vbTab & "(" & objFile.Size & ")"
  379. 			End If
  380. 		End If
  381. 		Set objFile = Nothing
  382. 	Next
  383. 	arrTemp.TrimToSize
  384. 	Set arrBitmaps = Nothing
  385. 	Set arrBitmaps = arrTemp.Clone( )
  386. 	Set arrTemp    = Nothing
  387. 	If blnDebug Then DisplayNames
  388. End Sub
  389.  
  390.  
  391. Sub ListFileNames( myFolder )
  392. 	If blnDebug Then
  393. 		WScript.Echo "Searching through """ & myFolder & """:"
  394. 	End If
  395. 	Dim objFile, objSubFolder
  396. 	Set arrBitmaps   = CreateObject( "System.Collections.ArrayList" )
  397. 	Set objFolder = objFSO.GetFolder( myFolder )
  398. 	Set objRE        = New RegExp
  399. 	objRE.Global     = False
  400. 	objRE.IgnoreCase = True
  401. 	strFileNameFilter = Replace( strFileNameFilter, ".", "\." )
  402. 	strFileNameFilter = Replace( strFileNameFilter, "*", "[-_~#$^&+,a-z0-9]*" )
  403. 	strFileNameFilter = Replace( strFileNameFilter, "?", "[-_~#$^&+,a-z0-9]" )
  404. 	If blnDebug Then
  405. 		WScript.Echo "File Name Filter       = " & strFileNameFilter
  406. 	End If
  407. 	For Each objFile In objFolder.Files
  408. 		objRE.Pattern    = "^" & strFileNameFilter & "$"
  409. 		Set colMatches   = objRE.Execute( objFile.Name )
  410. 		If colMatches.Count = 1 Then
  411. 			arrBitmaps.Add objFile.Path
  412. 			If blnDebug Then
  413. 				WScript.Echo "Adding   " & objFile.Path
  414. 			End If
  415. 		Else
  416. 			If blnDebug Then
  417. 				WScript.Echo "Skipping " & objFile.Path
  418. 			End If
  419. 		End If
  420. 	Next
  421. 	Set colMatches = Nothing
  422. 	Set objRE      = Nothing
  423. 	If blnRecursive Then
  424. 		If blnDebug Then
  425. 			WScript.Echo "Recursing:"
  426. 		End If
  427. 		For Each objSubFolder In objFolder.Folders
  428. 			ListFileNames( objFolder.Folders.Path )
  429. 		Next
  430. 	End If
  431. 	If blnDebug Then DisplayNames
  432. End Sub
  433.  
  434.  
  435. Function PickOne( )
  436. 	Dim objRandom, intRandom
  437. 	Set objRandom = CreateObject( "System.Random" )
  438. 	intRandom = objRandom.Next_2( 0, arrBitmaps.Count )
  439. 	If blnDebug Then
  440. 		WScript.Echo "Picking a random number from 0 to " & arrBitmaps.Count & ": " & intRandom & vbCrLf
  441. 	End If
  442. 	PickOne = arrBitmaps( intRandom )
  443. End Function
  444.  
  445.  
  446. Sub Syntax( errMsg )
  447. 	Dim StdIn, strMsg
  448. 	If errMsg <> "" And strScriptEnv = "WScript" Then WScript.Echo "Error: " & errMsg
  449. 	strMsg = "WallPaper.vbs,  Version 1.01 for Windows 2000 / XP" & vbCrLf _
  450. 	       & "Change Windows' wallpaper" & vbCrLf & vbCrLf _
  451. 	       & "Usage:   WALLPAPER.VBS [{ bitmap | folder [options] }] [/D:seconds] [/DEBUG]" & vbCrLf & vbCrLf _
  452. 	       & "Options: [/A:attrs] [/F:filespec] [/S] [/T:yyyymmdd] [/Z:bytes]" & vbCrLf & vbCrLf _
  453. 	       & "Where:   bitmap      The fully qualified path of the selected bitmap"     & vbCrLf _
  454. 	       & "         folder      Choose random bitmap from this folder (default " & wshShell.ExpandEnvironmentStrings( "%windir%" ) & ")" & vbCrLf _
  455. 	       & "         /A:attrs    Choose only from bitmaps with these attributes set (ACHRS)" & vbCrLf _
  456. 	       & "         /D:seconds  Wait number of seconds (useful when running at logon)"      & vbCrLf _
  457. 	       & "         /DEBUG      Verbose display of intermediate values (in CSCRIPT only)"   & vbCrLf _
  458. 	       & "         /F:filespec Choose only from files matching filespec (default *.BMP)"   & vbCrLf _
  459. 	       & "         /S          Recurse subdirectories" & vbCrLf _
  460. 	       & "         /T:yyyymmdd Choose only from files from this date or later"   & vbCrLf _
  461. 	       & "         /Z:bytes    Choose only from files of at least this size"     & vbCrLf & vbCrLf _
  462. 	       & "Examples:   Change wallpaper to specified bitmap after 120 seconds:"   & vbCrLf _
  463. 	       & "                     WALLPAPER.VBS  D:\MyPhotos\Edelweiss.bmp  /D:120" & vbCrLf _
  464. 	       & "            Randomly pick a read-only bitmap > 64KB from " & wshShell.ExpandEnvironmentStrings( "%windir%" ) & "\IMG*.BMP:" & vbCrLf _
  465. 	       & "                     WALLPAPER.VBS  /A:R  /F:""IMG*.BMP""  /Z:65537" & vbCrLf & vbCrLf _
  466. 	       & "Written by Rob van der Woude" & vbCrLf _
  467. 	       & "http://www.robvanderwoude.com"
  468. 	Display strMsg
  469. 	If errMsg <> "" And strScriptEnv = "CScript" Then Display vbCrLf & vbCrLf & vbCrLf & "Error: " & errMsg
  470. 	Set StdOut   = Nothing
  471. 	Set wshShell = Nothing
  472. 	Set objFSO   = Nothing
  473. 	WScript.Quit 1
  474. End Sub
  475.  

page last uploaded: 2017-07-06, 12:37