Wallpaper changer script for Windows XP

Posted: Monday, February 14th, 2011 at 8:57 pm by Lockworld Herald
Modified: Monday, February 14, 2011
Categories: Downloads, Level: Intermediate, Microsoft Windows, VBScript

Download Codes:
WallpaperChanger.zip Includes: WallpaperChanger.vbs & WallpaperChanger_Config.vbs

I’ve been using a linux-based Asus Eee PC (p701) for several years now, and one of my favorite features available is the desktop wallpaper “slideshow” option. I can set up my computer to randomly display a new desktop wallpaper as often as I want. All I have to do is point to the folder(s) the images are stored in and set the frequency, and viola my desktop wallpaper changes “automagically.”

I’ve almost given up on wallpapers for my home and office Windows machines, however. While it’s certainly not hard to change the desktop wallpaper, it’s not something I like to think about. To be honest, the desktop is always covered by the applications I’m working in, so I rarely even think about it. But a few months ago, I stumbled across the Microsoft Digital Photography Winter Fun Pack 2003. While most of the features are uninteresting to me, one of them caught my eye. The Winter Wallpaper Changer feature automatically changes your desktop wallpaper anywhere from once every 15 minutes to once a week. You can point the program to whatever folder you want that contains the background images. Even better, you can set it up so that on certain days (someone’s birthday, a holiday, or whatever), you can choose from a different set of wallpaper images!

I installed this application, and was immediately thrilled with how it worked. I like my wallpaper to change very frequently, so I had my wallpaper changed every fifteen minutes throughout the day. I never knew how easy it would be to brighten up my day just by changing my computer’s wallpaper!

Over the course of the next week, however, my enthusiasm for the application began to fade. I quickly realized that every morning when I logged in to my computer, the wallpaper slideshow started back at the beginning (the first image in my wallpapers folder). Since I rarely see my desktop wallpaper except when I log in or out, this meant that I kept seeing the same image every morning. This sort of defeats the purpose of changing the wallpaper (especially since the first image in my folder was one of my least favorite). I also noticed that every morning when I logged in to my computer, the program didn’t just start up in the background as I would have expected. Instead, I had to wait while Windows launched the installer program and re-installed (or possibly reconfigured?) the wallpaper changer. When it finished, instead of just running the program in the background, it opened up the user configuration dialog window. So I had to close that down before I could get to work for the day. Not a big deal, but a bit of a nuisance.

To make matters worse, I also realized that, even though I was very excited about the ability to override the wallpaper images on specific days, I was a bit disappointed in this feature overall. It worked exactly as advertised, and I quickly selected pictures to use on Christmas, Halloween, my kids’ birthdays, etc. But then I wondered what I would do for Thanksgiving. Since it doesn’t fall on the same day every year, I realized I could not have a specific set of wallpapers for that holiday. I also realized that I don’t always just want a particular wallpaper on a particular day. I thought it would be better to be able to have specific wallpapers for specific months. For October: Halloween pictures. For November: Fall pictures and Thanksgiving pictures. For December: Christmas pictures. For January: Winter pictures. You get the idea.

I quickly fell out of love with the Winter Wallpaper Changer from Microsoft. But I had become quite enamored with the idea of having my desktop wallpaper rotate automatically on a regular basis. So I decided I’d just go ahead and write my own desktop wallpaper changing script so I could build it the way I wanted it.

Below, I’ve included the source code for two VBS files (Visual Basic Scripts). These files can be edited with any text editor, but will run when double-clicked. Or, you can set them up as scheduled tasks (as I’ve done) so that they run automatically in the background on a pre-selected schedule.

NOTE: I was not able to find any way to automatically refresh the desktop to apply the new background images. Instead, this program will just select a random picture from your wallpapers folder, copy it to the “default” directory for your Windows desktop wallpaper, and update your registry settings to use the new file. You will probably not see a change until you log off the computer and log back on, or until Windows automatically refreshes the desktop (I think it does this about once every four hours).

Try it yourself:

For anyone who is interested, I’ve included the full code for both the WallpaperChanger.vbs and WallpaperChanger_Config.vbs files below. You can copy and paste the codes below into a text editor and save them to your computer (they must be in the same folder to work together). Of, if you prefer, you can download the zipped folder containing the two script files. Extract the contents to the same folder and they should work as-is.

Don’t forget to create a scheduled task to run the Wallpaperchanger.vbs script on a regular basis (I recommend only once at every login).

WallpaperChanger.vbs

Notes: This script, when run, will check for a text file called “WallpaperChanger Settings.txt” that holds the configuration settings it uses. If the text file is not found, it will call the WallpaperChanger_Config.vbs script (see code below) to configure and install the “WallpaperChanger Settings.txt”



     ' VBScript File

     Option Explicit

    '--------------------------------------------------------------
    '                   REFERENCES
    '--------------------------------------------------------------
    '
    ' Expected configuration settings file contents should be:
    '       configcontents(0) = "Wallpaper Directory:"
    '       configcontents(1) = {The configured Wallpaper Directory}
    '       configcontents(2) = vbNewLine
    '       configcontents(3) = "Current Wallpaper:"
    '       configcontents(4) = {The currently selected wallpaper filename}
    '       configcontents(5) = vbNewLine
    '       configcontents(6) = "Wallpaper Position:"
    '       configcontents(7) = {The configured wallpaper position}
    '           0 = Center
    '           1 = Tile
    '           2 = Stretch
    '       configcontents(8) = vbNewLine
    '       configcontents(9) = "Include 'My Pictures Slideshow?'"
    '       configcontents(10) = {Yes/No}
    '       configcontents(11) = vbNewLine
    '       configcontents(12) = "Wallpaper Last Changed:"
    '       configcontents(13) = {Timestamp of last change}
    '
    '---------------------------------------------------------------
    '            END REFERENCES
    '---------------------------------------------------------------

     '---------------------------------------------------
     ' Define variables used in script
     '---------------------------------------------------
        Dim _
        colFolders, _
        colSubfolders, _
        configcontents(), _
        configexists, _
        configfilepath, _
        configposition, _
        configslideshow, _
        da, _
        defFile, _
        edate, _
        expLines, _
        extName, _
        file, _
        folderPath, _
        ForAppending, _
        ForReading, _
        ForWriting, _
        foundlines, _
        FSO, _
        i, _
        logcontents, _
        logDirectory, _
        logexists, _
        logFile, _
        logText, _
        max, _
        min, _
        mo, _
        moday, _
        MyFiles, _
        MyFolder, _
        objFile, _
        objFolder, _
        objFSO, _
        objLogFile, _
        objNet, _
        objReadFile, _
        objShell, _
        objStream, _
        objSubfolder, _
        objWallFile, _
        objWMIService, _
        ofolder, _
        oSHApp, _
        scriptPath, _
        sdate, _
        selectedwallpaper, _
        SlideShow, _
        SlideFolder, _
        SPath, _
        strComputer, _
        strDesktop, _
        subFolder, _
        sUserName, _
        sWallPaper, _
        sWinDir, _
        SysFolder, _
        temp, _
        therand, _
        userreply, _
        varPathCurrent, _
        wallDirectory, _
        wallFile, _
        wallText

    '-------------------------
    ' Set script-level variables
    '-------------------------
        ' Create the File System Objects
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objNet = CreateObject("WScript.Network")
        Set objShell = CreateObject("WScript.Shell")
        Set oSHApp = CreateObject("Shell.Application")

        strComputer = "."
        Set objWMIService = GetObject("winmgmts:" _
            & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")

        ' Assign the file open/read variables
        ' (That won't be changed later in the program)
        ForAppending = 8
        ForReading = 1
        ForWriting = 2
        ' ForWriting will delete the existing contents before writing to the file

        ' Set the path to the default wallpaper.
        SPath = "C:\Documents and Settings\" & objNet.UserName _
        & "\Local Settings\Application Data\Microsoft"

        ' Find the path the the current WallpaperChanger script.
        scriptPath = Left(WScript.ScriptFullName, InstrRev(WScript.ScriptFullName, _
        WScript.ScriptName) -1)

        ' This is the path where the configuration settings file will be
        ' found (or created).
        wallDirectory = scriptPath

        ' Assigns the filename and path to search for or create the configuration
        ' settings file
        wallFile = "WallpaperChanger Settings.txt"

        ' Date variables
        mo = Month(Now())
        da = Day(Now())
        if (mo<10) then
            mo = "0" & mo
        else
            mo = "" & mo
        end if
        if (da<10) then
            da = "0" & da
        else
            da = "" & da
        end if

    On Error Resume Next
    Err.Clear

    '-------------------------
    ' Read the contents of the configuration settings file (or create a new file)
    '-------------------------
        ' Call a function to read the contents of the configuration settings file
        ' (or create one if it does not exist or if it is invalid).
        GetSetConfigFile()

    '-------------------------
    ' Call the Verify function to determine whether the configuration settings file
    ' was built correctly.
    '-------------------------
        VerifyConfigSettingsFileLines

    '-------------------------
    ' If file verifies, call a function to read it. Otherwise, call a
    ' function to re-create the file.
    '-------------------------
        if (explines = foundlines) then
            ' If the file passes verification, read the file
            ReadWallFile

        else
            ' If size indicates an error in wallFile, call CreateConfigurationSettingsFile
            ' function to recreate it.
            WScript.Echo "An error has occured with the configuration file: " _
            & vbNewLine & wallDirectory & wallFile & vbNewLine _
            & "Executing built-in pause for 5 seconds to rebuild file."
            WScript.Sleep(2500)
            ' I kept running into problems with the file still being seen as opened
            ' by this script when I tried to recreate it. So I adding this message
            ' box and built-in hold to ensure the file was properly closed before
            ' trying to re-create it.

            ModifyConfigurationSettingsfile

        end if

    '-------------------------
    ' Choose the new wallpaper
    '-------------------------
        ' Call a function to randomly select a new wallpaper for the user.
        SelectNewWallpaper

    '-------------------------
    ' Set the new wallpaper
    '-------------------------
        ' Call a function to set the user's new wallpaper in the Registry.
        '   NOTE: The new wallpaper will not be displayed until the screen is refreshed
        ' (every 3-4 hours, logging in, logging out, locking the screen, etc.)
        SetUserWallpaper

    ' Exit the application
    WScript.Quit

    '------------------------------------------
    '     FUNCTIONS
    '------------------------------------------

    Function GetSetConfigFile ()
        ' This function reads the contents of the Wallpaper Changer Configuration
        ' settings file. If no settings file exists, the user is prompted to create
        ' a new configuration settings file.

        On Error Resume Next
        Err.Clear

        '---------------------
        ' Look for the configuration settings file.
        '   If no configuration settings file exists, create and configure one now.
        '---------------------
            if objFSO.FolderExists(wallDirectory) then
                Set objFolder = objFSO.GetFolder(wallDirectory)
                ' This is redundant, as the configuration settings file path is
                '  automatically the path to this script itself. But I left it in in
                '  case I decide to allow the user to store the configuration
                '   settings file in a different location someday.
            else
                Set objFolder = objFSO.CreateFolder(wallDirectory)
                ' If the configuration settings file's parent folder does not exist,
                '  it will be created here. 

                '-------------------------
                ' OPTION: Uncomment the 2 lines below if you want the script to notify the
                '  user that the folder was created.
                '-------------------------
                '    WScript.Echo "Successfully installed configuration directory: " _
                '     & wallDirectory

            end if

            ' In either case above, the folder exists.
            ' Now, we look for the file itself.
            ' If it doesn't exist, we'll create it now and call the configuration
            '  function to prompt the user for input.
            if NOT(objFSO.FileExists(wallDirectory & wallFile)) then
                CreateConfigurationSettingsFile
                ' Call the function that creates the configuration settings file.
                '   NOTE: The CreateConfigurationSettingsFile will, in turn, call a
                '     separate script which will allow the user to review and modify
                '     the configuration settings for the program.
                '     Upon successful completion of the script, configexists
                '     variable is set to true.

            end if

        Set objFile = Nothing
        Set objFolder = Nothing

    End Function

    Function VerifyConfigSettingsFileLines ()
        ' This function will read the number of lines in the configuration
        '  settings file. If the number of lines in the file matches the number of
        '  expected lines, we can assume the configuration settings file was
        '  written correctly.

        On Error Resume Next
        Err.Clear

        '-------------------------
        ' Set the number of lines you expect to see in the configuration
        '  settings file.
        '-------------------------
            foundlines = 0
            explines = 14
            '-------------------------
            ' Count the number of lines in the existing configuration settings file
            '-------------------------
                Set objWallFile = objFSO.OpenTextFile (wallDirectory _
                  & wallFile, ForReading)
                i = 0
                Do Until objWallFile.AtEndOfStream
                temp = objWallFile.ReadLine
                i=i+1
                Loop
                objWallFile.close
                set objWallFile = Nothing

                ' Store the number of lines found into a variable for later use
                foundlines = i

    End Function

    Function ReadWallFile ()
        ' This function will read the configuration settings file and store each
        '  line in the array configcontents.

        On Error Resume Next
        Err.Clear

        ' If configuration settings file exists and passes verification, read it
        Set objWallFile = objFSO.OpenTextFile (wallDirectory & wallFile, ForReading)
        i=0

        'Save each line into an array variable
        Do Until objWallFile.AtEndOfStream
            Redim Preserve configcontents(i)
            configcontents(i) = objWallFile.ReadLine
            i=i+1
        Loop

        ' Close the file
        objWallFile.close
        Set objWallFile = Nothing

        if (configcontents(1) > "" AND configcontents(7) > "" _
          AND configcontents(10) > "") then
            configfilepath = configcontents(1)
            configposition = configcontents(7)
            configslideshow = configcontents(10)
            ' If file exists, passes verification, and contains acceptable entries,
            '  let the program know it exists.
            configexists = true
        else
            configexists = false
        end if

    End Function

    Function CreateConfigurationSettingsFile()
        ' This function will create a new configuration settings file and call a
        '   separate script to allow the user to review and modify
        '   the configuration settings for the program.

        On Error Resume Next
        Err.Clear

        Set objWallFile = objFSO.CreateTextFile (wallDirectory & wallFile, ForWriting)
        objWallFile.WriteLine("Wallpaper Directory:")
        objWallFile.WriteLine("C:\Documents and Settings\" & objNet.UserName _
            & "\My Documents\My Pictures")
        objWallFile.WriteLine("")
        objWallFile.WriteLine("Current Wallpaper:")
        objWallFile.WriteLine("")
        objWallFile.WriteLine("")
        objWallFile.WriteLine("Wallpaper Position:")
        objWallFile.WriteLine("2")
        objWallFile.WriteLine("")
        objWallFile.WriteLine("Include My Pictures Slideshow?")
        objWallFile.WriteLine("No")
        objWallFile.WriteLine("")
        objWallFile.WriteLine("Wallpaper Last Changed:")
        objWallFile.WriteLine("")

        ModifyConfigurationSettingsFile
        ' Calls a separate script to allow the user to review and modify the
        '   configuration settings for the program.

    End Function

    Function ModifyConfigurationSettingsFile()
        ' This function will call an external script to allow the user to review
        '   and modify the configuration settings file.

        On Error Resume Next
        Err.Clear

        temp = """" & scriptPath & "\WallpaperChanger_Config.vbs"""
        objShell.Run(temp)

    End Function

    Function SelectNewWallpaper()
        ' This function will find an appropriate wallpaper based on the user's
        '   preferred directory and any date-specific wallpaper preferences.

        On Error Resume Next
        Err.Clear

        if (configexists = true) then
            ' Verify that the selected wallpaper directory actually exists.
            '   If not, then give user the option to adjust settings or quit program
            If objFSO.FolderExists(configfilepath) then
                Set SysFolder = FSO.GetFolder(configfilepath)
            else
                userreply = msgbox("Unable to find the selected wallpaper directory. " _
                    & "Would you like to change your wallpaper changer " _
                    & "settings now?", vbYesNo)

                if (userreply = 6) then
                    ' If user agrees, call the configuration script to modify settings.
                    ModifyConfigurationSettingsFile

                end if

                ' Quit this script (will be re-run if/when user
                '   modifies configuration settings file).
                WScript.Quit

            end if

            Set MyFolder = FSO.GetFolder(configfilepath)
            folderPath = configfilepath

            '-------------------------
            ' Check for special "override" folder for a particular month, a
            '   particular day, or a particular date range
            '-------------------------
                Set MyFolder = FSO.GetFolder(configfilepath)
                folderPath = configfilepath
                ' Sets the default folder for images
                '   (in case folder selected below has no files).

                ' If a folder exists for a specific month...
                    if (objFSO.FolderExists(configfilepath & "\" & mo)) then
                        ' If no images in this folder, use the default folder
                        Set temp = FSO.GetFolder(configfilepath & "\" & mo)
                        if (temp.Files.Count > 0) then
                            Set MyFolder = FSO.GetFolder(configfilepath & "\" & mo)
                            folderPath = configfilepath & "\" & mo
                            moday = mo
                        end if
                    end if

                ' If a folder exists for a specific date range...
                    Set objFolder = objFSO.GetFolder(configfilepath)
                    Set colSubfolders = objFolder.Subfolders
                    For Each objSubfolder in colSubfolders
                        if (instr(1,objSubfolder.Name,"-") > 0) then
                            sdate = left(objSubfolder.Name, instr(1, _
                                objSubfolder.Name,"-")-1)
                            edate = right(objSubfolder.Name, InstrRev(_
                               objSubfolder.Name, "-")-1)
                            if ((mo & "_" & da) >= sdate _
                               AND (mo & "_" & da) <= edate) then
                                ' If no images in this folder, use the default folder
                                Set temp = FSO.GetFolder(configcontents(1) _
                                    & "\" & objSubfolder.Name)
                                if (temp.Files.Count > 0) then
                                    Set MyFolder = FSO.GetFolder(configcontents(1) _
                                       & "\" & objSubfolder.Name)
                                    folderPath = configcontents(1) & "\" _
                                       & objSubfolder.Name
                                    moday = objSubfolder.Name
                                end if
                            end if
                        end if
                    Next

                ' If a folder exists for a specific day...
                    if (objFSO.FolderExists(configfilepath & "\" & mo & "_" & da)) then
                        ' If no images in this folder, use the default folder
                        Set temp = FSO.GetFolder(configfilepath & "\" & mo _
                           & "_" & da)
                        if (temp.Files.Count > 0) then
                            Set MyFolder = FSO.GetFolder(configfilepath & "\" & mo _
                               & "_" & da)
                            folderPath = configcontents(1) & "\" & mo & "_" & da
                            moday = mo & "_" & da
                        end if
                    end if

            '-------------------------
            ' Select a random picture to use for the wallpaper
            '-------------------------
                max = MyFolder.Files.Count
                min = 1
                Randomize
                therand = Int((max-min+1) * Rnd+min)

                temp = ""
                i = 0

                ' Select a file with qualifying extension
                For each file in MyFolder.Files
                    i = i+1
                    extName = right(file.Name, 3)
                    if (extName="jpg" OR extName="JPG" OR extName="bmp" _
                       OR extName="BMP" OR extName="gif" _
                       OR extName="GIF") then
                        ' Get first file as default file
                        if (temp="") then
                            temp = file.Name
                            defFile = file.Name
                        end if

                        if (i=therand) then
                            temp = file.Name
                        end if
                    else
                        if (i=therand) then
                            min=i+1
                            Randomize
                            therand = Int((max-min+1)*Rnd+min)
                        end if
                    end if

                Next

                if (temp="") then
                    selectedwallpaper = defFile
                else
                    selectedwallpaper = temp
                end if

        else
            WScript.Quit
            ' Application has failed.
        end if

    End Function

    Function SetUserWallpaper()
        ' This function changes the registry settings to select the
        '  new wallpaper and other user preferences from the configuration
        '  settings file.

        On Error Resume Next
        Err.Clear

        if (isnull(selectedwallpaper) OR selectedwallpaper = "") then
            msgbox("No wallpaper found in " & folderPath & "\" _
               & selectedwallpaper)
        else
            ' Remove existing wallpaper file(s)
            if objFSO.FileExists(SysFolder & "\Wallpaper1.bmp") then
                objFSO.DeleteFile SysFolder & "\Wallpaper1.bmp"
            end if

            if objFSO.FileExists(SysFolder & "\Wallpaper1.jpg") then
                objFSO.DeleteFile SysFolder & "\Wallpaper1.jpg"
            end if

            if objFSO.FileExists(SysFolder & "\Wallpaper1.gif") then
                objFSO.DeleteFile SysFolder & "\Wallpaper1.gif"
            end if

            objFSO.CopyFile folderPath & "\" & selectedwallpaper , SPath _
               & "\" & "Wallpaper1." & right(selectedwallpaper, 3)

            ' Update the settings file
            Set objWallFile = objFSO.CreateTextFile (wallDirectory _
               & wallFile, ForWriting)

            objWallFile.WriteLine("Wallpaper Directory:")
            objWallFile.WriteLine(configfilepath)
            objWallFile.WriteLine("")
            objWallFile.WriteLine("Current Wallpaper:")
            if (configfilepath = folderPath) then
                objWallFile.WriteLine(selectedwallpaper)
            else
                objWallFile.WriteLine(moday & "\" & selectedwallpaper)
            end if
            objWallFile.WriteLine("")
            objWallFile.WriteLine("Wallpaper Position:")
            objWallFile.WriteLine(configposition)
            objWallFile.WriteLine("")
            objWallFile.WriteLine("Include 'My Pictures Slideshow?'")
            objWallFile.WriteLine(configslideshow)
            objWallFile.WriteLine("")
            objWallFile.WriteLine("Wallpaper Last Changed:")
            objWallFile.WriteLine(Now())

            objWallFile.close
            Set objWallFile = Nothing

            ' Set the selected wallpaper as the Windows desktop wallpaper
            sWallPaper = SPath & "\" & "Wallpaper1." & right(temp, 3)

            ' update in registry
            objShell.RegWrite "HKCU\Control Panel\Desktop\Wallpaper", _
               sWallPaper
            if (configposition=1) then
                objShell.RegWrite "HKCU\Control Panel\Desktop\TileWallpaper", 1
            else
                objShell.RegWrite "HKCU\Control Panel\Desktop\TileWallpaper", 0
            end if
            if (wallPosition > -1 AND wallPosition < 3) then
               objShell.RegWrite "HKCU\Control Panel\Desktop\WallpaperStyle", _
                   configposition
            else
               objShell.RegWrite "HKCU\Control Panel\Desktop\WallpaperStyle", 2
            end if

            if (configslideshow="Yes") then
                objShell.RegWrite "HKEY_CURRENT_USER\Control Panel\" _
                    & "Screen Saver.Slideshow\ImageDirectory", FolderPath

            end if
            ' let the system know about the change
            objShell.Run "%windir%\System32\RUNDLL32.EXE " _
               & "user32.dll,UpdatePerUserSystemParameters", 1,True

        end if

    End Function

WallpaperChanger_Config.vbs

Notes: This script, when run, will create or update a text file called “WallpaperChanger Settings.txt” that holds the configuration settings used by “WallpaperChanger.vbs.” The user settings control which directory holds the wallpaper, which image folder to use, and whether or not the same directory should be used for the Windows Slideshow screensaver.



    ' VBScript File

     Option Explicit

    Dim _
    configcontents(), _
    configexists, _
    configfilepath, _
    configimage, _
    configposition, _
    configslideshow, _
    currentImage, _
    defFile, _
    explines, _
    extName, _
    file, _
    ForAppending, _
    ForReading, _
    ForWriting, _
    foundlines, _
    FSO, _
    i, _
    logcontents, _
    logDirectory, _
    logexists, _
    logFile, _
    logText, _
    MyFolder, _
    MyFiles, _
    objFile, _
    objFolder, _
    objFSO, _
    objLogFile, _
    objNet, _
    objReadFile, _
    objShell, _
    objStream, _
    objWallFile, _
    ofolder, _
    oldFilePath, _
    oSHApp, _
    scriptPath, _
    SPath, _
    strComputer, _
    strDesktop, _
    sUserName, _
    sWinDir, _
    sWallPaper, _
    SysFolder, _
    temp, _
    uinput, _
    userPath, _
    userFile, _
    wallDirectory, _
    wallFile, _
    wallText

    '-------------------------
    ' Set script-level variables
    '-------------------------
        ' Create the File System Objects
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objNet = CreateObject("WScript.Network")
        Set objShell = CreateObject("WScript.Shell")
        Set oSHApp = CreateObject("Shell.Application")

        ' Assign the file open/read variables
        '   (That won't be changed later in the program)
        ForAppending = 8
        ForReading = 1
        ForWriting = 2
            ' ForWriting will delete the existing contents before
            '   writing to the file

        ' Find the path the the current
        '   WallpaperChanger script.
        scriptPath = Left(WScript.ScriptFullName, _
           InstrRev(WScript.ScriptFullName, _
           WScript.ScriptName) -1)

        ' This is the path where the configuration settings file
        '   will be found (or created).
        wallDirectory = scriptPath

        ' Assigns the filename and path to search for or
        '   create the configuration settings file
        wallFile = "WallpaperChanger Settings.txt"

    '-------------------------
    ' Read the contents of the configuration settings file
    '   (or create a new file)
    '-------------------------
        ' Call a function to read the contents of the
        '   configuration settings file (or create one if it
        '   does not exist or if it is invalid.
        GetSetConfigFile()

    '-------------------------
    ' Call the Verify function to determine whether the
    '   configuration settings file was built correctly.
    '-------------------------
        VerifyConfigSettingsFileLines

    '-------------------------
    ' If file verifies, call a function to read it. Otherwise,
    '   call a function to re-create the file.
    '-------------------------
        if (explines <> foundlines) then
            ' If size indicates an error in wallFile, call
            '   CreateConfigurationSettingsFile function to
            '   recreate it
            WScript.Echo "An error has occured with the" _
                & "configuration file: " & vbNewLine & wallDirectory _
                & wallFile & vbNewLine & "Executing built-in" _
                & " pause for 5 seconds to rebuild file."
            WScript.Sleep(2500)

            CreateConfigurationSettingsFile

        end if

        if (explines = foundlines) then
            ' If the file passes verification, read the file
            ReadWallFile

        else
            '-------------------------
            ' OPTION: Uncomment the 3 lines below to include
            '   a failure message before quitting the application
            '-------------------------
            '    WScript.Echo "The application was not able to" _
            '   & " read or create the configuration file." _
            '   & " Please try again later."

            ' If after two tries, file doesn't verify, quit silently
            WScript.Quit

        end if

      ' Prompt user for changes
      GetUserInput

      ' Run WallPaperChanger.vbs
      temp = """" & scriptPath & "\WallpaperChanger.vbs"""
      objShell.Run(temp)

      objWallFile.close
      Set objWallFile = Nothing

      Set objFSO = Nothing
      Set objNet = Nothing
      Set objShell = Nothing
      Set oSHApp = Nothing
      WScript.Quit

    '------------------------------------------
    '     FUNCTIONS
    '------------------------------------------

    Function GetSetConfigFile ()
        ' This function reads the contents of the Wallpaper
        '   Changer Configuration settings file.
        '   If no settings file exists, the user is prompted to
        '   create a new configuration settings file.

        On Error Resume Next
        Err.Clear

        '---------------------
        ' Look for the configuration settings file.
        '   If no configuration settings file exists, create and
        '   configure one now.
        '---------------------
            if objFSO.FolderExists(wallDirectory) then
                Set objFolder = objFSO.GetFolder(wallDirectory)
                ' Folder exists!
                ' This is redundant, as the configuration settings
                '   file path is automatically the path to this
                '   script itself. But I left it in in case I decide to
                '   allow the user to store the configuration
                '   settings file in a different location someday.
            else
                Set objFolder = objFSO.CreateFolder(wallDirectory)
                ' If the configuration settings file's parent folder
                '   does not exist, it will be created here.

                '-------------------------
                ' OPTION: Uncomment the 3 lines below if you
                '   want the script to notify the user that the
                '   folder was created.
                '-------------------------
                '    WScript.Echo "Successfully installed" _
                '       & " configuration directory: " _
                '       & wallDirectory

            end if

            ' In either case above, the folder exists. Now, we
            '   look for the file itself.
            ' If it doesn't exist, we'll create it now and call the
            '   configuration function to prompt the user for input.
            if NOT(objFSO.FileExists(wallDirectory & wallFile)) then
                CreateConfigurationSettingsFile
                ' Call the function that creates the configuration settings file.
                '   NOTE: The CreateConfigurationSettingsFile will, in turn,
                '   call a separate script which will allow the user to
                '   review and modify the configuration settings for the program.
                '   Upon successful completion of the script, configexists
                '   variable is set to true.

            end if

        ' Close the file
        objWallFile.close
        Set objWallFile = Nothing

        Set objFile = Nothing
        Set objFolder = Nothing

    End Function

    Function VerifyConfigSettingsFileLines ()
        ' This function will read the number of lines in the configuration settings file.
        '   If the number of lines in the file matches the number of expected lines,
        '   we will assume the configuration settings file was written correctly.

        On Error Resume Next
        Err.Clear

        '-------------------------
        ' Set the number of lines you expect to see in the configuration settings file
        '-------------------------
            foundlines = 0
            explines = 14
            '-------------------------
            ' Count the number of lines (i) in the existing configuration settings file
            '-------------------------
                Set objWallFile = objFSO.OpenTextFile (wallDirectory _
                   & wallFile, ForReading)
                i = 0
                Do Until objWallFile.AtEndOfStream
                temp = objWallFile.ReadLine
                i=i+1
                Loop

                ' Close the file
                objWallFile.close
                Set objWallFile = Nothing

                ' Store the number of lines found into a variable for later use
                foundlines = i

    End Function

    Function ReadWallFile ()
        ' This function will read the configuration settings file and store each line in the
        '   array configcontents.

        On Error Resume Next
        Err.Clear

        ' If configuration settings file exists and passes verification, read it
        Set objWallFile = objFSO.OpenTextFile (wallDirectory & wallFile, ForReading)
        i=0

        ' Save each line into an array variable
        Do Until objWallFile.AtEndOfStream
            Redim Preserve configcontents(i)
            configcontents(i) = objWallFile.ReadLine
            i=i+1
        Loop

        ' Close the file
        objWallFile.close
        Set objWallFile = Nothing

        if (configcontents(1) > "" _
          AND configcontents(7) > "" AND configcontents(10) > "") then
            configfilepath = configcontents(1)
            configposition = configcontents(7)
            configslideshow = configcontents(10)
            configimage = configcontents(3)
            ' If file exists, passes verification, and contains acceptable entries,
            '   let the program know it exists
            configexists = true
        else
            configexists = false
        end if

    End Function

    Function CreateConfigurationSettingsFile()
        ' This function will create a new configuration settings file and call a
        '   separate script to allow the user to review and modify
        '   the configuration settings for the program.

        On Error Resume Next
        Err.Clear

        Set objWallFile = objFSO.CreateTextFile (wallDirectory & wallFile, ForWriting)
        objWallFile.WriteLine("Wallpaper Directory:")
        objWallFile.WriteLine("C:\Documents and Settings\" & objNet.UserName _
            & "\My Documents\My Pictures")
        objWallFile.WriteLine("")
        objWallFile.WriteLine("Current Wallpaper:")
        objWallFile.WriteLine("")
        objWallFile.WriteLine("")
        objWallFile.WriteLine("Wallpaper Position:")
        objWallFile.WriteLine("2")
        objWallFile.WriteLine("")
        objWallFile.WriteLine("Include My Pictures Slideshow?")
        objWallFile.WriteLine("No")
        objWallFile.WriteLine("")
        objWallFile.WriteLine("Wallpaper Last Changed:")
        objWallFile.WriteLine("Never")

        ' Close the file
        objWallFile.close
        Set objWallFile = Nothing

        WScript.Sleep 10000

        GetSetConfigFile

        VerifyConfigSettingsFileLines

    End Function

    Function GetUserInput()

        ' This function uses Internet Explorer to
        ' create a dialog and prompt for user input.
        '
        ' Version:             2.10
        ' Last modified:       2010-09-28
        '
        ' Argument:   [string] prompt text, e.g. "Please enter your name:"
        ' Returns:    [string] the user input typed in the dialog screen
        '
        ' Written by Rob van der Woude
        ' http://www.robvanderwoude.com
        ' Error handling code written by Denis St-Pierre
            Dim objIE

            ' Create an IE object
            Set objIE = CreateObject( "InternetExplorer.Application" )

            ' Specify some of the IE window's settings
            objIE.Navigate "about:blank"
            objIE.Document.Title = "Wallpaper Changer Configuration"
            objIE.ToolBar        = False
            objIE.Resizable      = True
            objIE.StatusBar      = False
            objIE.Width          = 700
            objIE.Height         = 500

            ' Center the dialog window on the screen
            With objIE.Document.ParentWindow.Screen
                objIE.Left = (.AvailWidth  - objIE.Width ) \ 2
                objIE.Top  = (.Availheight - objIE.Height) \ 2
            End With

            ' Precompile combo boxes to use correctly selected data
            dim ttov1, ttov2, ttov3
            ttov1 = ""
            ttov2 = ""
            ttov3 = ""
            if (configposition = "0") then
                ttov1 = " selected"
            end if
            if (configposition = "1") then
                ttov2 = " selected"
            end if
            if (configposition = "2") then
                ttov3 = " selected"
            end if

            dim ss
            ss = ""

            if (configslideshow = "Yes") then
                ss = " selected"
            end if

            ' Wait till IE is ready
            Do While objIE.Busy
                WScript.Sleep 200
            Loop
            ' Insert the HTML code to prompt for user input
            objIE.Document.Body.InnerHTML = "<div align=""left""><h4>Custom Wallpaper " _
               & "Configuration Settings:</h4>" & vbCrLf _
               & "<p><b>Enter the path to your wallpapers folder: </b><br/><input " _
               & "type=""text"" size=""20"" " _
               & "id=""UserPath"" value=""" & configfilepath & """></p>" & vbCrLf _
               & "<p><b>Select how you want your wallpaper to appear: " _
               & "</b><br/>" _
               & "<select id=""TileType"" value=""" & configposition & """>" & vbCrLf _
               & "  <option value=""0""" & ttov1 & ">Center</option>" & vbCrLf _
               & "  <option value=""1""" & ttov2 & ">Tile</option>" _
               & vbCrLf & "  <option value=""2""" & ttov3 _
               & ">Stretch</option>" & vbCrLf _
               & "</select>" & vbCrLf _
               & "<p><b>Use the same directory for the ""My Pictures Slideshow"" " _
               & "screensaver?</b><br/>" & vbCrLf _
               & "<select id=""Slideshow"" value=""" & configslideshow _
               & """>" & vbCrLf _
               & "  <option value=""No"">No</option>" & vbCrLf _
               & "  <option value=""Yes""" & ss & ">Yes</option" & vbCrLf _
               & "</select></p>" & vbCrLf _
               & "<p><input type=""hidden"" id=""OK"" " _
               & "name=""OK"" value=""0""><br/>" _
               & "<input type=""submit"" value="" OK "" " _
               & "OnClick=""VBScript:OK.Value=1""></p></div>"
            ' Hide the scrollbars
            objIE.Document.Body.Style.overflow = "auto"
            ' Make the window visible
            objIE.Visible = True
            ' Set focus on input field
            objIE.Document.All.UserPath.Focus

            ' Wait till the OK button has been clicked
            On Error Resume Next
            Do While objIE.Document.All.OK.Value = 0
                WScript.Sleep 200
                ' Error handling code by Denis St-Pierre
                If Err Then
                ' user clicked red X (or alt-F4) to close IE window
                    IELogin = Array( "", "" )
                    objIE.Quit
                    Set objIE = Nothing
                    Exit Function
                End if
            Loop
            On Error Goto 0

            ' Read the user input from the dialog window
            ' and save it to the settings file

            Set objWallFile = objFSO.CreateTextFile (wallDirectory & wallFile, True)

            objWallFile.WriteLine("Wallpaper Directory:")
            objWallFile.WriteLine(objIE.Document.All.UserPath.Value)
            objWallFile.WriteLine("")
            objWallFile.WriteLine("Current Wallpaper:")
            objWallFile.WriteLine(configcontents(4))
            objWallFile.WriteLine("")
            objWallFile.WriteLine("Wallpaper Position:")
            objWallFile.WriteLine(objIE.Document.All.TileType.Value)
            objWallFile.WriteLine("")
            objWallFile.WriteLine("Include 'My Pictures Slideshow?'")
            objWallFile.WriteLine(objIE.Document.All.Slideshow.Value)
            objWallFile.WriteLine("")
            objWallFile.WriteLine()
            objWallFile.WriteLine(Now())

            ' Close and release the object
            objIE.Quit
            Set objIE = Nothing

            MsgBox("Your settings have been saved!")
    End Function

That’s all for today…now get out there and Write the Web!

This entry was posted on Monday, February 14th, 2011 at 8:57 pm and is filed under Downloads, Level: Intermediate, Microsoft Windows, VBScript. You can follow any responses to this entry through the RSS 2.0 feed. You can leave a response, or trackback from your own site.

Wallpaper changer script for Windows XP

Leave a Reply