Option Explicit

'Wallpaper and Roaming Profile script
'Matt Waddell | 7th June 2007
'http://www.mattwaddell.com

On Error Resume Next

Dim objShell, objFso
Dim regUserDesktop, regOriginalWallpaper
Dim strOriginalWallpaper, strUserProfile, strWallpaper, strRoamingWallpaperFilename
Dim fsoFile
Dim returnCode

Set objShell = CreateObject("WScript.Shell")
Set objFso = CreateObject ("Scripting.FileSystemObject")

regUserDesktop = "HKCU\Control Panel\Desktop\"
strOriginalWallpaper = "OriginalWallpaper"
strWallpaper = "Wallpaper"
strRoamingWallpaperFilename = "\Wallpaper.bmp"

strUserProfile = objShell.ExpandEnvironmentStrings("%USERPROFILE%")
regOriginalWallpaper = objShell.RegRead(regUserDesktop & strOriginalWallpaper)

'Is the current wallpaper not a bitmap?
If InStr(regOriginalWallpaper,"Local Settings") > 0 Then
  'Copy the current wallpaper to a roaming profile location
  Set fsoFile = objFso.GetFile(regOriginalWallpaper)
  returnCode = fsoFile.Copy(strUserProfile & strRoamingWallpaperFilename,1)
  'Set the WallPaper registry key to the new location
  returnCode = objShell.RegWrite(regUserDesktop & strWallpaper,strUserProfile & strRoamingWallpaperFilename)
  'Set the OriginalWallPaper registry key to the new location
  returnCode = objShell.RegWrite(regUserDesktop & strOriginalWallpaper,strUserProfile & strRoamingWallpaperFilename)
End If