' ===========
' SwitchLinks
' ===========
' Version 1.0.3.15 - January 1st 2020
' Copyright © Steve MacGuire 2010-2020
' http://samsoft.org.uk/iTunes/SwitchLinks.vbs
' Please visit http://samsoft.org.uk/iTunes/scripts.asp for updates

' =======
' Licence
' =======
' This program is free software: you can redistribute it and/or modify it under the terms
' of the GNU General Public License as published by the Free Software Foundation, either
' version 3 of the License, or (at your option) any later version.

' This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; 
' without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
' See the GNU General Public License for more details.

' Please visit http://www.gnu.org/licenses/gpl-3.0-standalone.html to view the GNU GPLv3 licence.

' ===========
' Description
' ===========
' A VBScript to rename a selection of iTunes tracks using information from the tag/library.

' Related scripts: ConsolidateByMoving, ConsolidateByMovingLong, CustomRenamer, ExportToFolder, SwitchLinks

' =========
' ChangeLog 
' =========
' Version 1.0.0.1 - Initial version
' Version 1.0.0.2 - Allow for inclusion of trailing artist in filename for compilation albums
' Version 1.0.0.3 - Replace/omit characters that are not valid in filenames
' Version 1.0.0.4 - Minor tweaks
' Version 1.0.0.5 - Detect path of iTunes Library.xml and use as root for file target location
' Version 1.0.0.6 - Translate "The Artist" into "Artist, The", trim spaces & trailing periods which may create inaccessible folders (OUCH!)
' Version 1.0.0.7 - GNU GPLv3.0 Release
' Version 1.0.0.8 - Update for tracks with no track number to avoid "00 Track Name.ext" 
' Version 1.0.0.9 - If file already exists at target location simply switch iTunes to point to it, fix potential for excessive path length
' Version 1.0.1.1 - Update to use common track selection & reporting routines
' Version 1.0.1.2 - Manage supplementary files, e.g. album artwork, if all tracks from an album move to new folder
' Version 1.0.1.3 - Generate folder artwork after moving files if missing, manage "promoted" art, report existing files instead of switching
' Version 1.0.1.4 - Option to create iTunes standard file & folder names
' Version 1.0.1.5 - Detect pre & post iTunes 9 media folders
' Version 1.0.1.6 - Minor correction to match iTunes folder naming scheme more closely
' Version 1.0.2.1 - Updated to new common code base with progress bar
' Version 1.0.2.2 - Extend to work with iPod Games and Mobile Applications
' Version 1.0.2.3 - Extend to work with iTunes LP & iTunes Extras
' Version 1.0.2.4 - Optionally delete old file if it already exists in the new location
' Version 1.0.2.5 - Extend for Voice Memos and changed Ringtones to Tones folder
' Version 1.0.2.6 - Update to custom rules for Classical albums
' Version 1.0.2.7 - Fix file names, or album/artist folder names that needs a casing change to match tag
' Version 1.0.2.8 - Ignore repeated items in regular playlists
' Version 1.0.2.9 - Fix PersistentObject function for MobileApps
' Version 1.0.3.0 - Tweak personal structure 
' Version 1.0.3.1 - Tweak personal structure again
' Version 1.0.3.2 - Updated common code
' Version 1.0.3.3 - Update to GetMediaPath and tweaks to personal structure
' Version 1.0.3.4 - Added new ExportToFolder mode
' Version 1.0.3.5 - New option to switch links from one path to another
' Version 1.0.3.6 - New option for custom renaming using keyword patterns
' Version 1.0.3.7 - Tweak for iTunes Extras & LP version numbers
' Version 1.0.3.8 - Tweak to suppress unwanted sero disc or track numbers
' Version 1.0.3.9 - Added index number to pattern keywords for playlist export
' Version 1.0.3.10 - Minor correction for iBooks
' Version 1.0.3.11 - Tweaks for TV Shows, rename as <EpisodeID> <Name>.<Ext>
' Version 1.0.3.12 - Make MaxPath configurable
' Version 1.0.3.13 - Option to suppress trailing (year) in folder names
' Version 1.0.3.14 - Improved handling of larger track numbers when using patterns
' Version 1.0.3.15 - Try to catch file naming error


' ==========
' To-do List
' ==========
' Handle error if file moves would require an overwrite. Done! Simply switch link from one copy to the other,
' ---- however if two different files (i.e. dupes exist) this might not be what is wanted. Needs more thought
' Extend options to include bit for handling promoted artwork
' Option to use Sort Album & Sort Album Artist where present for folder names
' Option for rule sets, e.g. Mine, iTunes Standard, Amazon (if I can work out what they are) etc.
' Handle SD/HD video sets
' Add things to do

' =============================
' Declare constants & variables
' =============================
' Variables for common code
' Modified 2014-04-09
Option Explicit	        ' Declare all variables before use
Dim Intro,Outro,Check   ' Manage confirmation dialogs
Dim PB,Prog,Debug       ' Control the progress bar
Dim Clock,T1,T2,Timing  ' The secret of great comedy
Dim Named,Source        ' Control use on named playlist
Dim Playlist,List       ' Name for any generated playlist, and the object itself
Dim iTunes              ' Handle to iTunes application
Dim Tracks              ' A collection of track objects
Dim Count               ' The number of tracks
Dim D,M,P,S,U,V         ' Counters
Dim nl,tab              ' New line/tab strings
Dim IDs                 ' A dictionary object used to ensure each object is processed once
Dim Rev                 ' Control processing order, usually reversed
Dim Quit                ' Used to abort script
Dim Title,Summary       ' Text for dialog boxes
Dim Tracing             ' Display/suppress tracing messages

' Values for common code
' Modified 2016-02-29
' Const Kimo=True       ' True if script expects "Keep iTunes Media folder organised" to be disabled (Declaration moved)
Const Min=1             ' Minimum number of tracks this script should work with
Const Max=0             ' Maximum number of tracks this script should work with, 0 for no limit
Const Warn=500          ' Warning level, require confirmation for processing above this level
Intro=True              ' Set false to skip initial prompts, avoid if non-reversible actions
Outro=True              ' Produce summary report
Check=True              ' Track-by-track confirmation, can be set during Intro
Prog=True               ' Display progress bar, may be disabled by UAC/LUA settings
Debug=True              ' Include any debug messages in progress bar
Timing=True             ' Display running time in summary report
Source=""               ' Named playlist to process, use "Library" for entire library
Rev=False               ' Control processing order, usually reversed
Debug=True              ' Include any debug messages in progress bar
Tracing=True            ' Display tracing message boxes


' Additional variables for this particular script
' Modified 2018-09-18
Dim Check2              ' Alternate check flag
Dim FSO                 ' Handle to FileSystemObject
Dim SH                  ' Handle to Shell application
Dim Reg                 ' Handle to Registry object
Dim NewPath             ' New path for the current track, use globally to save calculating twice
Dim Root                ' Root of media library
Dim Library             ' Location of main library
Dim Org                 ' Media organisation flag
Dim Std                 ' Use iTunes naming (True) or longer filenames (False)
Dim Pers                ' Use for extended naming rules, rewrite these for your own use
Dim Thumbs              ' Generate "promoted" thumbnails for artists with single albums
Dim SendToTrash         ' If a file exists in both new and old locations send the old file to trash, or delete directly if UseTrash is false
Dim UseTrash            ' Attempt to send local deleted files to trash 
Dim Export,Pattern      ' Variables for export mode
Dim Switch,Custom       ' More mode flags
Dim RegEx               ' Regular expression object
Dim KillYear            ' Suppress trailing (year) in folder names

' Initialise variables for this particular script
' Modified 2018-09-18
Root=""                 ' Preset target folder, set here to avoid second dialog 
SendToTrash=True        ' Don't use if both paths could refer to the same file
UseTrash=True           ' Attempt to send local deleted files to trash
Const MaxPath=250       ' Prevent path growing too long, may need tweaking down to prevent copy errors later
KillYear=True           ' Suppress trailing (year) in folder names


' Enable one set of options below for alternate versions of this script.

' Title="Consolidate By Moving"
' Const Kimo=False : Custom=False : Export=False : Std=True : Pers=False : Switch=False : Thumbs=False
' Summary="Move files to current or new media folder without leaving unwanted copies behind."

' Title="Consolidate By Moving Long"
' Const Kimo=True : Custom=False : Export=False : Std=False : Pers=False : Switch=False : Thumbs=False
' Summary="Move files to current or new media folder without leaving unwanted copies behind, using long file and folder names."

' Title="Custom Renamer"
' Const Kimo=True : Custom=True : Export=False : Std=False : Pers=False : Switch=False : Thumbs=False : KillYear=True
' Summary="Rename files and folders using custom rename pattern."
' Pattern="Music\<AlbumArtist>\<Album>\<TrackNumber> <Name>"
' If Pattern<>"" Then Summary=Summary & vbCrLf & vbCrLf & "E.g. :  " & Pattern

' Title="Export To Folder"
' Const Kimo=False : Custom=False : Export=True : Std=False : Pers=False : Switch=False : Thumbs=False : KillYear=False
' Summary="Copy files to new media folder with a user selectable pattern."
' Pattern=""
' If Pattern<>"" Then Summary=Summary & vbCrLf & vbCrLf & "E.g. " & Pattern

' Title="Filename From Tag"
' Const Kimo=True : Custom=False : Export=False : Std=False : Pers=True : Switch=False : Thumbs=True
' Summary="Rearrange files to my personal preferences."

Title="Switch Links"
Const Kimo=True : Custom=False : Export=False : Std=False : Pers=False : Switch=True : Thumbs=False : SendToTrash=False : KillYear=False
Summary="Swap links from one media folder to another. Tracks must exist on matching paths in the two folders."
Dim OldRoot,NewRoot
OldRoot=""
NewRoot=""
If OldRoot<>"" And NewRoot<>"" Then Summary="Swap links from " & OldRoot & " to " & NewRoot & ". Tracks must exist on matching paths in the two folders."


' Initialize global objects
Set FSO=CreateObject("Scripting.FileSystemObject")
Set SH=CreateObject("Shell.Application")
Set Reg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") 	' Use . for local computer, otherwise could be computer name or IP address
Set RegEx=CreateObject("VBScript.RegExp")
RegEx.Global=True   
RegEx.IgnoreCase=True
RegEx.Pattern=" \(\d{4}\)\\"    ' Matches on a substring such as " (2018)\", i.e. a trailing year in a folder name in a file path


' ============
' Main program
' ============

GetTracks               ' Set things up
GetRoot                 ' More setup
ProcessTracks 	        ' Main process 
Report                  ' Summary

' ===================
' End of main program
' ===================


' ===============================
' Declare subroutines & functions
' ===============================


' Note: The bulk of the code in this script is concerned with making sure that only suitable tracks are processed by
'       the following module and supporting numerous options for track selection, confirmation, progress and results.


' Move iTunes object to new path, uses global NewPath set elsewhere
' Modified 2020-01-01
Sub Action(Track)
  Dim A,B,Ext,F,I,H,L,NewArtist,NewFolder,NewName,OldArtist,OldFolder,OldName,OldPath,Playlists,R,S,Status,VK
  With Track
    VK=.VideoKind                               ' Preserve VideoKind
    OldPath=FSO.GetAbsolutePathName(.Location)
    OldName=FSO.GetFileName(OldPath)
    OldFolder=FSO.GetParentFolderName(OldPath)
    OldArtist=FSO.GetParentFolderName(OldFolder) 
    NewName=FSO.GetFileName(NewPath)
    NewFolder=FSO.GetParentFolderName(NewPath)
    NewArtist=FSO.GetParentFolderName(NewFolder)
    Ext=Mid(NewPath,InStrRev(NewPath,"."))
    If Export Then                              ' Copy file to new path
      MakePath(NewFolder)
      FSO.CopyFile .Location,NewPath
      U=U+1
    ElseIf Instr(".ite.itlp",LCase(Ext)) Then   ' Manage iTunes LP & Extras
      If FSO.FolderExists(NewPath) Then         ' Seems to be an existing copy of target
        FSO.CopyFolder .Location,NewPath        ' Copy in case existing version is incomplete
        If SendToTrash Then Recycle .Location   ' Recycle folder?
      Else
        MakePath(NewFolder)
        FSO.MoveFolder .Location,NewPath
      End If
      Set Playlists=.Playlists                  ' Note playlist membership  
      If LCase(Ext)=".ite" Then
        NewName=Left(NewName,Instr(NewName," - iTunes Extras")-1) & " - iTunes Extras.ite"
      End If
      If LCase(Ext)=".itlp" Then
        NewName=Left(NewName,Instr(NewName," - iTunes LP")-1) & " - iTunes LP.itlp"
      End If
      NewPath=NewPath & "\" & NewName           ' .ite/.itlp file to add back, without version number
      StartEvent                                ' Time potentially slow event
      If Prog Then PB.SetDebug "Removing: " & .Location
      H=iTunes.ITObjectPersistentIDHigh(Track)
      L=iTunes.ITObjectPersistentIDLow(Track)
      Set Track=iTunes.LibraryPlaylist.Tracks.ItemByPersistentID(H,L)
      Track.Delete                              ' Remove existing reference
      If Prog Then PB.SetDebug "Adding: " & NewPath
      Set Status=iTunes.LibraryPlaylist.AddFile(NewPath)
      If IsNull(Status) Then
        MsgBox "There was a problem reimporting the file " & nl & path & nl & nl & "Please do so manually.",0,Title
      Else
        Set Track=Status.Tracks(1)
        ' Reinsert track into non-smart user playlists
        If Prog Then PB.SetDebug "Restoring to playlists"
        For I=1 To Playlists.Count
          If Playlists.Item(I).Smart=False Then
            Playlists.Item(I).AddTrack(Track)
          End If
        Next
      End If
      StopEvent                                 ' Show event time
      If Thumbs Then CreateFolderArt(Track)
      MoveArt OldFolder,NewFolder
      U=U+1                                     ' Increment updated tracks
    ElseIf Not FSO.FileExists(NewPath) Or LCase(NewPath)=LCase(.Location) Then
      ' Correct case discrepancies in pre-existing artist or album folders
      If FileCaseDiffers(OldFolder,NewFolder) Then FSO.MoveFolder OldFolder,NewFolder
      If FileCaseDiffers(OldArtist,NewArtist) Then FSO.MoveFolder OldArtist,NewArtist
      A=.AlbumArtist : If A="" Then A=.Artist : If A="" Then A="Unknown Artist"
      B=.Album : If B="" Then B="Unknown Album"
      If Prog Then PB.SetInfo "Moving: " & A & " - " & B & " - " & .Name
      Set F=FSO.GetFile(.Location)
      MakePath(NewFolder)
      If Not FSO.FileExists(NewPath) Or LCase(NewPath)=LCase(.Location) Then
        On Error Resume Next                    ' Trap possible error
        F.Move(NewPath)                         ' Move file to new path
        If Err.Number<>0 Then
          Trace Track,"Error setting location to:" & nl & NewPath & nl & "(" & Len(NewPath) & " chars)"
          NewPath=.Location                     ' Prevent incorrect updating of unmoved file
        End If
        On Error Goto 0                         ' Restore standard error handler
      End If
      StartEvent                                ' Time potentially slow event
      If .Location<>FSO.GetAbsolutePathName(NewPath) Then .Location=NewPath
      If .VideoKind<>VK Then .VideoKind=VK      ' Reset VideoKind
      StopEvent                                 ' Show event time
      If NewName="iQuiz.ipg" Then
        If FSO.FolderExists(OldFolder & "\sample1") Then FSO.MoveFolder OldFolder & "\sample1",NewFolder & "\sample1"
      End If
      If Thumbs Then CreateFolderArt(Track)
      MoveArt OldFolder,NewFolder
      U=U+1                                     ' Increment updated tracks
    Else
      If SendToTrash Then Recycle .Location     ' Delete old copy of file if necessary
      On Error Resume Next                      ' Trap possible error
      .Location=NewPath                         ' Switch link to new version already in place
      If Err.Number<>0 Then
        Trace Track,"Error setting location to:" & nl & NewPath
      End If
      If Export=False and Switch=False Then
        If Thumbs Then CreateFolderArt(Track)
        MoveArt OldFolder,NewFolder
      End If
      U=U+1                                     ' Increment updated tracks
    End If
  End With
End Sub


' Create folder artwork for current file if missing
' Modified 2011-11-06
Sub CreateFolderArt(Track)
  Dim Art,Artwork,F,Folder,P,Parent,Path
  With Track
    Folder=Left(.Location,InStrRev(.Location,"\")-1)
    Path=Folder & "\Folder.jpg"
    If Not FSO.FileExists(Path) Then
      Set Artwork=.Artwork
      If Artwork.Count>0 Then
        Set Art=Artwork.Item(1)
        Art.SaveArtworkToFile(Path)
        'MsgBox "Just created artwork!" & nl & nl & "Does iTunes crash now?"
        If Art.IsDownloadedArtwork Then Art.SetArtworkFromFile(Path)		' Will embed art, but won't be processed on subsequent files from the same album
        'MsgBox "Just embedded artwork!" & nl & nl & "Does iTunes crash now?"
        Set F=FSO.GetFile(Path)
        Parent=Left(Folder,InStrRev(Folder,"\")-1)         
        Set P=FSO.GetFolder(Parent)
	      F.Attributes=(F.Attributes OR 6)
        If Thumbs And P.SubFolders.Count=1 Then
          ' Only one album subfolder for artist, promote thumbnail if possible
	        If FSO.FileExists(Parent & "\Folder.jpg")=False Then
            F.Copy Parent & "\Folder.jpg"
          End If
        Else
          ' More than one album subfolder for artist, remove thumbnail in artist folder if it exists and is not read-only
          If FSO.FileExists(Parent & "\Folder.jpg") Then
            Set F=FSO.GetFile(Parent & "\Folder.jpg")
            If (F.Attributes AND 1)=0 Then F.Delete
	        End If            
        End If
      End If  
    End If
  End With
End Sub


' True if files paths are similar but the last segment differs only in case
' Modified 2012-06-11
Function FileCaseDiffers(A,B)
  FileCaseDiffers=LCase(A)=LCase(B) And FSO.GetFileName(A)<>FSO.GetFileName(B)
End Function


' Generate file path on tag properties
' Modified 2020-01-01
Function FilenameFromTag(Track)
  Dim C,F,K,R,T,Ext,NewFolder,NewName,OldAlbum,OldFolder,OldName,Seq,SortArtist,ValidAlbum,ValidArtist
  With Track
    Ext=LCase(Mid(.Location,InStrRev(.Location,".")))
    OldFolder=Left(.Location,InStrRev(.Location,"\")-1)
    OldName=Mid(.Location,InStrRev(.Location,"\")+1)
    OldName=Left(OldName,Len(OldName)-Len(Ext))
    
    If Switch Then
      NewPath=Replace(.Location,OldRoot,NewRoot,1,-1,1)
      'MsgBox .Location & nl & OldRoot & nl & NewRoot & nl & NewPath,0,Title
      FileNameFromTag=NewPath
      Exit Function                     ' Skip the rest of the function, we're done
    End If
    
    If Custom Or Export Then            ' Keywords are: <Album>,<AlbumArtist>,<Artist>,<Composer>,<DiscNumber>,<Genre>,<Grouping>,<Index>,<Name>,<TrackNumber>,<Year>
      K=Root & Pattern & Ext
      K=Replace(K,"<Album>",.Album,1,-1,1)
      K=Replace(K,"<AlbumArtist>",.AlbumArtist,1,-1,1)
      K=Replace(K,"<Artist>",.Artist,1,-1,1)
      K=Replace(K,"<Composer>",.Composer,1,-1,1)
      K=Replace(K,"<EpisodeID>",.EpisodeID,1,-1,1)
      K=Replace(K,"<Genre>",.Genre,1,-1,1)
      K=Replace(K,"<Grouping>",.Grouping,1,-1,1)
      K=Replace(K,"<Name>",.Name,1,-1,1)
      K=Replace(K,"<Show>",TheValidFolder(.Show),1,-1,1)
      K=Replace(K,"<Year>",.Year,1,-1,1)
      ' Pad out disc numbers to size of disc count
      If Instr(1,Pattern,"<DiscNumber>",1) Then
        C=Len(.DiscCount)
        Seq=Right(String(C,"0") & .DiscNumber,C)
        K=Replace(K,"<DiscNumber>",Seq,1,-1,1)
      End If
      ' Pad out index numbers to size of exported list
      If Instr(1,Pattern,"<Index>",1) Then
        C=Len(Count)
        If C<4 Then C=4
        Seq=Right(String(C,"0") & U+1,C)
        K=Replace(K,"<Index>",Seq,1,-1,1)
      End If
      ' Pad out track numbers to at least two digits, or size of track count, or size of track number
      If Instr(1,Pattern,"<TrackNumber>",1) Then
        C=Len(.TrackCount)
        If C<2 Then C=2
        If .TrackNumber>99 And C<3 Then C=3
        Seq=Right(String(C,"0") & .TrackNumber,C)
        K=Replace(K,"<TrackNumber>",Seq,1,-1,1)
      End If
      ' Suppress unwanted substrings here
      K=Replace(K,"\Disc 0\","\",1,-1,1)                        ' No disc folder for disc 0
      If .DiscCount=1 Then K=Replace(K,"\Disc 1\","\",1,-1,1)   ' No disc folder for disc 1 of 1
      K=Replace(K,"\00 - ","\",1,-1,1)                          ' No track number for track 0
      K=Replace(K,"\00-","\",1,-1,1)                            ' No track number for track 0
      K=Replace(K,"\00 ","\",1,-1,1)                            ' No track number for track 0
      If KillYear Then K=RegEx.Replace(K,"\")
      ' Replace any invalid characters here
      NewPath=ValidPath(K)
      FileNameFromTag=NewPath
      Exit Function                     ' Skip the rest of the function, we're done
    End If
    
    'Edit the following lines to enforce your desired folder/filename structure
    'E.g. could add rule here to use Composer instead of Artist if Genre is Classical or Choral etc.

    ValidArtist=.AlbumArtist & ""       ' N.b. adding "" prevents null value errors 
    If ValidArtist="" Then ValidArtist=.Artist & ""
    If ValidArtist="" Then ValidArtist="Unknown Artist"
    If Std Then         'Use iTunes naming
      ValidArtist=ValidiTunes(ValidArtist,"")
    Else                'Use full length names with any leading "The " transposed to a trailing ", The"
      ValidArtist=TheValidFolder(ValidArtist)
    End If
    SortArtist=.SortAlbumArtist & ""
    If SortArtist="" Then SortArtist=ValidArtist & ""
    If Instr(SortArtist,",") Then SortArtist=Left(SortArtist,Instr(SortArtist,",")-1)

    ValidAlbum=.Album & ""
    If ValidAlbum="" Then ValidAlbum="Unknown Album"
    If Pers Then
      ' Fix special cases here first
      If .Album="Greatest Hits - Fleetwood Mac [CBS]" Then ValidAlbum="Greatest Hits [CBS]"
      If .Album="Greatest Hits - Fleetwood Mac [Warner]" Then ValidAlbum="Greatest Hits [Warner]"    
      'Strip trailing album artist name out of the album title if present
      'See http://samsoft.org.uk/iTunes/grouping.asp for why it might be...
      If Instr(ValidAlbum," - " & .AlbumArtist) And .Genre<>"Soundtrack" Then ValidAlbum=Left(ValidAlbum,InStr(.Album," - " & .AlbumArtist)-1)
    End If
    If Std Then         'Use iTunes naming
      ValidAlbum=ValidiTunes(ValidAlbum,"")
    Else                'Use full length names with any leading "The " transposed to a trailing ", The"
      ValidAlbum=TheValidFolder(ValidAlbum)
    End If
    
    'Is it an App?
    If Ext=".ipa" Then                  'Note old school layout puts apps and games in library folder
      If Org Then NewFolder=Root & "Mobile Applications" Else NewFolder=Library & "Mobile Applications"
    'Is it an iPod Game?
    ElseIf Ext=".ipg" Then
      If Org Then NewFolder=Root & "iPod Games" Else NewFolder=Library & "iPod Games"
      If Pers Then NewFolder=NewFolder & "\" & TheValidFolder(.Name)                    'My current structure
    'Is it an iTunes U file?            'Need a proper test for iTunesU MediaKind & correct folder property
    ElseIf Instr(OldFolder,"\iTunes U\") Or .Genre="iTunes U" Then
      If Pers Then
        ValidAlbum=TheValidFolder(.Album) 
        ' NewFolder=Root & "iTunes U\" &  ValidAlbum
        NewFolder=Root & "Podcasts\" &  ValidAlbum              'For iTunes 12.7
      Else
        ' Don't change the folder name otherwise new episodes may end up somewhere different
        NewFolder=Root & Mid(OldFolder,InStr(OldFolder,"\iTunes U\")+1)      
      End If
    'Is it a Podcast?                   'Need to establish correct podcast folder naming property
    ElseIf Instr(OldFolder,"\Podcasts\") Or .Podcast=True Then
      'Use standard iTunes folder names otherwise new episodes end up somewhere different
      ValidAlbum=ValidiTunes(.Album,"")
      'Or put in an override here...
      If Pers And ValidAlbum="8 Out Of 10 Cats 2009" Then ValidAlbum="8 Out Of 10 Cats"
      If Pers And ValidAlbum="- The Naked Scientists Podcast - Strippi" Then ValidAlbum="The Naked Scientists Podcast"
      If Pers And ValidAlbum="In Our Time With Melvyn Bragg" Then ValidAlbum="In Our Time"
      If Pers And ValidAlbum="Science of Attraction featuring Derren B" Then ValidAlbum="Science of Attraction"
      NewFolder=Root & "Podcasts\" & ValidAlbum
    'Is it a Home Video file?           'Need a proper test for Home Movies
    ElseIf Instr(OldFolder,"\Home Videos") Then
      If Pers Then
        NewFolder=Root & "Home Videos\" & ValidArtist
      Else
        NewFolder=Root & "Home Videos"
      End If
    'Is it a Movie?
    ElseIf .VideoKind=1 And (.Show & "")=""  Then       'Note VideoKind is not reliably set by iTunes
      If Org Then
        If Not(Pers And Ext=".ite") Then ValidAlbum=.Name
        If Std Then ValidAlbum=ValidiTunes(ValidAlbum,"") Else ValidAlbum=TheValidFolder(ValidAlbum)
        NewFolder=Root & "Movies\" & ValidAlbum
      Else  
        NewFolder=Root & "Movies"
      End If
    'Is it a TV Show?                                   'Note Disc# & Track# are applied by iTunes, not EpisodeNumber 
    ElseIf .VideoKind=3 Or (.Show & "")<>"" Then        'Note VideoKind is not reliably set by iTunes
      ValidAlbum=.Show
      If Std Then
        ValidAlbum=ValidiTunes(ValidAlbum,"")
      Else
        ValidAlbum=TheValidFolder(ValidAlbum)
      End If
      NewFolder=Root & "TV Shows\" & ValidAlbum
      If Pers And Instr("|Pixar|Trailers|",.Show) Then
        If Instr(.Name,"Toy Story Toons") Then
          NewFolder=Root & "TV Shows\Pixar\Toy Story Toons"
        Else
          NewFolder=Root & "TV Shows\" & TheValidFolder(.Show) & "\" & TheValidFolder(.Name)
        End If
      End If
      If Not Pers And Org And .SeasonNumber>0 Then NewFolder=NewFolder & "\Season " & .SeasonNumber
    'Is it an Audiobook?                'Again need a better test for Audiobook MediaKind, note old school treats audiobooks like music
    ElseIf .Genre="Audiobook" Or .Genre="Books & Spoken" Or .Genre="Spoken & Audio" Or Instr(.Location,"\Audiobooks\") Then
      If Pers Then
        NewFolder=Root & "Audiobooks\" & ValidArtist & "\"
        If .Grouping="Bromeliad Trilogy" Then                                               
          NewFolder=NewFolder & ValidFolder(.SortAlbum)                                 ' Use SortAlbum to group series together
        ElseIf .DiscNumber>0 Or .Album="The Hitchhiker's Guide To The Galaxy" Then      ' Special case for Hitchhiker's Guide
          If .DiscNumber<10 Then NewFolder=NewFolder & "0"                              ' And disc number to sort in series order
          NewFolder=NewFolder & .DiscNumber & " " & ValidFolder(.Album)
        Else
          NewFolder=NewFolder & ValidAlbum
        End If
      ElseIf Std Then
        NewFolder=Root & "Audiobooks\" & ValidArtist
      Else
        NewFolder=Root & "Audiobooks\" & ValidArtist & "\" & ValidAlbum
      End If
    'Is it a Book?                      'And for Book MediaKind
    ElseIf (.Genre="PDF" Or .Genre="PDF Document" Or Ext=".epub" Or Instr(OldFolder,"\Books")>0) And Left(.Name,18)<>"Digital Booklet - " Then
      NewFolder=Root & "Books\" & ValidArtist
    'Is it a Ringtone?
    ElseIf Ext=".m4r" Then
      NewFolder=Root & "Ringtones"
    'Is it a Voice Memo?
    ElseIf .Genre="Voice Memo" Then     '(Ext=".m4a" And .Bitrate=64)
      NewFolder=Root & "Voice Memos"
    'If we get this far file should be Music, Music Video, iTunes LP or Digital Booklet
    Else
      If Pers Then                      'My personal structure
        If .KindAsString="Apple Music AAC audio file" Then
          NewFolder=Root & "Apple Music\" & ValidArtist & "\" & ValidAlbum              'My current structure
        ElseIf Instr(.Grouping,"Unverified") Then
          NewFolder=Root & "Unverified\" & ValidArtist & "\" & ValidAlbum               'My current structure
        ElseIf Instr(.Grouping,"Dupe/DRM") Then
          NewFolder=Root & ValidArtist & "\" & ValidAlbum                               'My current structure
        ElseIf Instr("\Classical\Choral\Opera\","\" & .Genre & "\") Then                'Or Instr(.Location,"\Classical\") 
          NewFolder=Root & "Classical\" & SortArtist & "\" & ValidAlbum                 'My current structure
        ElseIf Instr(.Genre,"Comedy") Or Instr(.Location,"\Comedy\") Then
          NewFolder=Root & "Comedy\" & ValidArtist & "\" & ValidAlbum                   'My current structure
        'ElseIf Instr(.Location,"\Golden Oldies\") Then
        '  NewFolder=Root & "Miscellany\Golden Oldies\" & ValidArtist & "\" & ValidAlbum - Retired option
        ElseIf Instr(.Grouping,"iTalk") Then
          NewFolder=Root & "File Sharing\iTalk"                                         'My current structure   
        ElseIf Instr(.Grouping,"Misc") Then
          NewFolder=Root & "Miscellany\" & ValidAlbum                                   'My current structure  
        ElseIf .Genre="Soundtrack" Then
          NewFolder=Root & "Soundtracks\" & ValidAlbum                                  'My current structure
        ElseIf .AlbumArtist="Various Artists" Then                                      'Or .Compilation=True 
          NewFolder=Root & "Various Artists\" & ValidAlbum                              'My current structure
          'NewFolder=Root & "Music\Various Artists\" & ValidAlbum                       'Possible change for me
        ElseIf Instr("0123456789",Left(ValidArtist,1)) Then
          NewFolder=Root & "Albums & Tracks\123\" & ValidArtist & "\" & ValidAlbum      'My current structure
          'NewFolder=Root & "Music\123\" & ValidArtist & "\" & ValidAlbum               'Possible change for me
        ElseIf Instr("¡",Left(ValidArtist,1)) Then
          NewFolder=Root & "Albums & Tracks\" & Mid(ValidArtist,2,1) & "\" & ValidArtist & "\" & ValidAlbum     'My current structure (special case)
          'NewFolder=Root & "Music\" & Mid(ValidArtist,2,1) & "\" & ValidArtist & "\" & ValidAlbum              'Possible change for me (special case)
        Else
          NewFolder=Root & "Albums & Tracks\" & UCase(Left(ValidArtist,1)) & "\" & ValidArtist & "\" & ValidAlbum   'My current structure
          'NewFolder=Root & "Music\" & UCase(Left(ValidArtist,1)) & "\" & ValidArtist & "\" & ValidAlbum            'Possible change for myself
          'NewFolder=Root & "Music\" & ValidArtist & "\" & ValidAlbum				                                    'Post iTunes 9 Media Organisation
          'NewFolder=Root & ValidArtist & "\" & ValidAlbum					                                            'Pre iTunes 9 Media Organisation
        End If     
        If Instr(.Grouping,"Dupe/DRM") Then
          NewFolder=Replace(NewFolder,"\iTunes Media\","\Originals & Dupes\DRM Backups\")
          If .Enabled=True Then .Enabled=False
        ElseIf Instr(.Grouping,"Dupe") Then
          NewFolder=Replace(NewFolder,"\iTunes Media\","\Originals & Dupes\")
          If .Enabled=True Then .Enabled=False
        ElseIf Instr(.Grouping,"Exclude") Or Instr(.Grouping,"Non-iPod") Or Instr(.Grouping,"Unverified") Then
          If .Enabled=True Then .Enabled=False
        Else 
          If .Enabled=False Then .Enabled=True
        End If        
      Else        
        If Std And .Compilation=True Then ValidArtist="Compilations"
        If Org Then
	        NewFolder=Root & "Music\" & ValidArtist & "\" & ValidAlbum
        Else
	        NewFolder=Root & ValidArtist & "\" & ValidAlbum
        End If
      End If
    End If
    
    NewPath=NewFolder & "\"
    
    ' New path has been determined, time to focus on the track name
    
    If Ext=".ipa" Then
      NewName=OldName                   'No obvious naming rules for Mobile Apps/Voice Memos
    ElseIf .Genre="Voice Memo" Then
      If Pers Then NewName=.Name Else NewName=OldName
    Else    
      NewName=.Name
      ' Add leading two-digit track number & space unless track number is unset
      ' Special cases for Hitchhiker's Guide... etc.
      If .Name="Hitchhiker's Guide..., Chapter 0" Then
        NewName="00 " & NewName
      ElseIf .Name="The Now Show, Season 22, Show 0 [Podcast Trial Ended]" Then
        NewName="22.00 " & NewName      
      ElseIf .Name="Series 3 Teaser" Then
        NewName="3.00 " & NewName
      ElseIf .TrackNumber>0 Then
        NewName=.TrackNumber & " " & NewName
        If .TrackNumber<10 Then NewName="0" & NewName
        If Pers And .TrackNumber<100 And .TrackCount>99 Then NewName="0" & NewName
        ' Add optional disc no.
        If .DiscNumber>1 Or (.DiscNumber=1 And .DiscCount>1) Or .VideoKind=3 Or (.Show & "")<>"" Then
          If Pers Then
            If .Album="David Mitchell's SoapBox" Or .Album="I'm Sorry I Haven't A Clue" Or .Album="The Now Show" Or .Album="The Onion Radio News" Or .VideoKind=3 Or (.Show & "")<>"" Then
              If .DiscNumber>0 Then
                NewName=.DiscNumber & "." & NewName
                If .DiscCount>9 and .DiscNumber<10 Then NewName="0" & NewName
                If .DiscCount<100 And .DiscCount>99 Then NewName="0" & NewName
              End If
            End If
          Else
            If Not Pers Then NewName=.DiscNumber & "-" & NewName
          End If
        End If
      End If
      ' Check for TV Show
      If Pers And .VideoKind=3 Then
        If (.EpisodeID & "") <> "" Then
          ' Use EpisodeID if present
          If .EpisodeID<>LCase(.EpisodeID) Then .EpisodeID=LCase(.EpisodeID)
          NewName=.EpisodeID & " " & .Name          
        Else
          NewName=.EpisodeNumber & " " & NewName
          If .EpisodeNumber<10 Then NewName="0" & NewName
          If .EpisodeNumber<100 And .TrackCount>99 Then NewName="0" & NewName
          If .DiscNumber>0 Then
            NewName=.DiscNumber & "." & NewName
            If .DiscCount>9 and .DiscNumber<10 Then NewName="0" & NewName
            If .DiscCount<100 And .DiscCount>99 Then NewName="0" & NewName
          End If
        End If
      End If
    End If

    ' Avoid renaming iTunes LP & Extras folder to preserve version numbers
    If Instr(".ite.itlp",LCase(Ext)) Then
      NewName=OldName
    End If
    ' Insert custom rename here if required
    If Pers Then
      If NewName="Oceania - iTunes LP" Then NewName=NewName & " (v1.0)"
    End If
    
    If Std Then
      NewPath=NewPath & ValidiTunes(NewName,Ext)
    Else
      NewPath=NewPath & ValidFile(NewName)
    End If
       
    If Pers Then                      'My personal structure
      'Add trailing artist name when Artist<>AlbumArtist, e.g. for Various Artist album. Skip for Podcasts, Soundtracks, Voice Memos
      If .Artist<>.AlbumArtist And .AlbumArtist<>"" And .Artist<>"" And .Podcast=False And .Genre<>"Soundtrack"  And .Genre<>"Voice Memo" Then
        If .Genre="Classical" Then 
          If .Composer<>.AlbumArtist And .Composer<>"" Then NewPath=NewPath & " - " & ValidFile(.Composer)        
        Else
          NewPath=NewPath & " - " & ValidFile(.Artist)
        End If  
      End If
    End If

    If Not Pers Then Ext=Mid(.Location,InStrRev(.Location,".")) ' Restore current case of file extension
    NewPath=NewPath & Ext
    
    ' Use the following lines for manual renames
    ' NewPath=InputBox("Edit path/filename for:" & nl & nl & _
    '   "Album Artist : " & AlbumArtist & nl & _
    '   "Artist : " & Artist & nl & _
    '   "Album : " & Album & nl & _
    '   "Track : " & TrackNumber & " " & Name,Title,NewPath)

    If Len(NewPath)>MaxPath Then NewPath=Trim(Left(NewPath,MaxPath-Len(Ext))) & Ext
    
    ' Ready to move file, note NewPath is a global variable which will be used by Action if this file is actually moved
    FilenameFromTag=NewPath
    
  End With
End Function


' Attempt to determine root of media path by inspecting location of media files
' Modified 2016-01-02
Function GetMediaPath
  Dim A,C,I,L,P,S,T,Tracks
  Set Tracks=iTunes.LibraryPlaylist.Tracks
  C=Tracks.Count
  If C>100 Then C=100		' Give up if can't find one valid location in the first 100 attempts
  I=1
  P=""
  Do
    Set T=Tracks.Item(I)
    If T.Kind=1 Then		' Only process "File" tracks
      With T
        L=Replace(.Location,"/","\")    ' Correct paths from a migrated library
        If L<>"" Then
          P=L
          S=InstrRev(P,"\")
          ' Search for .iTunes Preferences.plist
          Do
            P=Left(P,S-1)
            S=InstrRev(P,"\")
          Loop Until S=0 Or FSO.FileExists(P & "\.iTunes Preferences.plist")
          ' If no .plist file make best guess
          If Not FSO.FileExists(P & "\.iTunes Preferences.plist") Then
            A=ValidiTunes(.AlbumArtist & "","")
            If A="" Then A=ValidiTunes(.Artist & "","")
            If A="" Then A="Unknown Artist"
            If .Compilation And Instr(L,A)=0 Then A="Compilations"
            If .Podcast Then
              A=ValidiTunes(.Album & "","")
            ElseIf .VideoKind=1 Then
              A=ValidiTunes(.Name & "","")
            ElseIf .VideoKind=3 Then
              A=ValidiTunes(.Show & "","")
            End If
            If A="" Then A="Unknown"
            If Instr(L,A) Then
              P=Left(L,Instr(L,A)-2)
              If InStr(P,"\") Then S=Mid(P,InStrRev(P,"\")) Else S=P
              If Instr("\Audiobooks\Books\iPod Games\iTunes U\Mobile Applications\Movies\Music\Podcasts\Ringtones\Tones\TV Shows\Voice Memos",S) Then P=Left(P,Len(P)-Len(S))
            Else
              'MsgBox "Artist:" & .Artist & nl & "Name:" & .Name & nl & "Location:" & .Location
            End If
          End IF 
        End If
      End With
    End If
    I=I+1
  Loop Until P<>"" OR I>C
  ' MsgBox "Media path is " & P & nl & "Found in " & I-1 & " step" & Plural(I-1,"s","")
  GetMediaPath=P
End Function


' Get custom/export pattern
' Modified 2016-03-15
Sub GetPattern
  Dim Q
  If Pattern="" Then Pattern="<Artist>\<Album>\<TrackNumber> <Name>"
  Q="Please confirm/edit the pattern to be used for the "
  If Custom Then Q=Q & "renamed" Else Q=Q & "copied"
  Q=Q & " files." & nl & nl & "(Note the pattern is not checked for validity.)"
  Pattern=InputBox(Q,Title,Pattern)
End Sub


' Get iTunes Media folder
' Modified 2016-03-15
Sub GetRoot
  Dim F,Q,R
  If Switch Then GetRoots : Exit Sub
  Library=iTunes.LibraryXMLPath
  Library=Left(Library,InStrRev(Library,"\")-1)
  ' If Root<>"" Then If FSO.FolderExists(Root)=False Then Root=""
  If Root="" Then
    Root=GetMediaPath
    F=False
    If Root="" Then
      Root=Library
      If FSO.FolderExists(Root & "\iTunes Media") Then Root=Root & "\iTunes Media"
      If FSO.FolderExists(Root & "\iTunes Music") Then Root=Root & "\iTunes Music"
    End If
  End If
  Q="Please confirm/edit the location of the media folder within which the files will be "
  If Export Then Q=Q & "copied." Else Q=Q & "moved/renamed."
  Do
    Root=InputBox(Q,Title,Root)
    If Right(Root,1)="\" Then Root=Left(Root,Len(Root)-1)
    If Root="" Then WScript.Quit
    If Not FSO.FolderExists(Root) Then
      R=MsgBox("The folder " & Root & " does not exist." & nl & nl & "Shall I create it?",vbYesNoCancel+vbQuestion,Title)
      If R=vbCancel Then WScript.Quit
      'If R=vbYes Then MakePath(Root)     ' Folder can be created if/when we actually move a file into it
      If R=vbYes Then F=True
    End If
  Loop Until F Or FSO.FolderExists(Root)
  If Right(Root,1)<>"\" Then Root=Root & "\"
  If Right(Library,1)<>"\" Then Library=Library & "\"
  Org=(Layout="1")
  If Custom Or Export Then GetPattern
End Sub


' Get root paths for link switching
' Modified 2016-03-04
Sub GetRoots
  Dim Q,R
  If Intro=False And FSO.FolderExists(OldRoot) And FSO.FolderExists(NewRoot)And OldRoot<>NewRoot Then ExitSub
  Do 
    Q="Please confirm/edit the OLD parent folder that is to be replaced in file paths."
    R=InputBox(Q,Title,OldRoot)
  Loop Until R="" Or FSO.FolderExists(R)
  If R="" Then WScript.Quit   ' Abort on empty input
  OldRoot=R
  Do 
    Q="Please confirm/edit the NEW parent folder that will be updated in the file paths."
    R=InputBox(Q,Title,NewRoot)
  Loop Until R="" Or (FSO.FolderExists(R) And R<>OldRoot)
  If R="" Then WScript.Quit   ' Abort on empty input
  NewRoot=R
End Sub


' Custom info message for progress bar
' Modified 2016-01-02
Function Info(T)
  Dim A,B
  With T
    A=""
    On Error Resume Next      ' Trap possible error
    A=.AlbumArtist & ""
    If Err.Number<>0 Then
      ' Trace T,"Error reading AlbumArtist from object: " & .Name
    End If   
    If A="" Then A=.Artist & "" : If A="" Then A="Unknown Artist"
    B=.Album & "" : If B="" Then B="Unknown Album"
    Info="Checking: " & A & " - " & B & " - " & .Name 
  End With
End Function


' Determine iTunes Media folder layout
' Modified 2012-08-28
Function Layout
  Dim File,Line,P,Prefs
  Layout="1"            ' Assume new style layout unless proved otherwise
  Prefs=Root & ".iTunes Preferences.plist"
  If Not FSO.FileExists(Prefs) Then Exit Function
  Set File=FSO.OpenTextFile(Prefs,1)
  Do While Not File.AtEndOfStream
    Line=File.ReadLine
    P=Instr(Line,"<integer>")
    If P>0 Then
      Layout=Mid(Line,P+9,1)
      Exit Do
    End If
  Loop
  File.Close
End Function


' Create a folder path if it doesn't already exist
' Modified 2011-09-17
Function MakePath(Path)
  ' Default result
  MakePath=False
  ' Fail if drive is not valid
  If Not FSO.DriveExists(FSO.GetDriveName(Path)) Then Exit Function
  ' Succeed if folder exists
  If FSO.FolderExists(Path) Then
    MakePath=True
    Exit Function
  End If
  ' Call self to ensure parent path exists
  If Not MakePath(FSO.GetParentFolderName(Path)) Then Exit function
  ' Create folder
  On Error Resume Next
  FSO.CreateFolder Path
  MakePath=FSO.FolderExists(Path)    
End Function


' Test for media files or subfolders, if none found move remaining files to new path, then delete folder
' Modified 2016-12-27
Sub MoveArt(ByVal OldPath,ByVal NewPath)
  Dim Files,E,F,M,NF,NP,OF,OP
  If FSO.FolderExists(OldPath)=False Then Exit Sub      ' Nothing to do... 
  Set OF=FSO.GetFolder(OldPath)
  If FSO.FolderExists(NewPath)=False Then
    MsgBox "iTunes has changed the path of the last file that was copied from" & nl & OldPath & " to " & nl & NewPath & "." _
      & nl & nl& "Please disable the ""Keep iTunes Media folder organised"" option" & nl & "or choose another target folder.",vbInformation,title
      Quit=True
    Exit Sub
  End If
  Set NF=FSO.GetFolder(NewPath)
  ' Allow for special case when moving files from Artist folder to Arist\Album folder
  If OF.Subfolders.Count=0 OR (OldPath=FSO.GetParentFolderName(NewPath) And NF.SubFolders.Count=0) Then
    Set Files=OF.Files
    If Files.Count>0 Then
      ' There are some files, any media ones?
      M=False
      For Each F in Files
        E=LCase(Right(F.Name,4))
        If Instr(".mp3.mp4.m4a.m4b.m4p.m4v.mov.mpg.mpeg.wav.aif.aiff.mid.ipa.ipg.ite.itlp.m4r.epub..ibooks.pdf",E) Then M=True : Exit For
      Next
      ' If no media files shift everything else
      If M=False Then
        For Each F in Files
	        ' If target folder already has a Folder.jpg image it is likely to be "fresher" so delete the one from the source folder
	        If LCase(F.Name)="folder.jpg" And FSO.FileExists(NewPath & "\Folder.jpg") Then
	          F.Delete
	        ElseIf LCase(F.Name)="thumbs.db" And FSO.FileExists(NewPath & "\Thumbs.db") Then
	          F.Delete
	        ElseIf LCase(Left(F.Name,8))="albumart" And FSO.FileExists(NewPath & "\" & F.Name) Then
	          F.Delete
	        ElseIf FSO.FileExists(NewPath & "\" & F.Name)=False Then
            F.Move(NewPath & "\")
          Else
            If M=False Then
              M=True
              SH.Explore OldPath
              MsgBox "Unable to move all remaining non-media files from folder" & nl & OldPath & nl & nl & "Please check and tidy if required.",vbInformation,title
            End If
          End If
        Next
      End If
    End If
    If Files.Count=0 Then
      ' The folder is now/was empty of art so remove it unless it contains subfolders (the special case above)
      If OF.Subfolders.Count=0 Then
        RmDir OldPath
      ElseIf OF.Subfolders.Count>1 Then
        SH.Explore NewPath
        MsgBox "There may be artwork for more than one album in the folder" & nl & NewPath & nl & nl & "Please check and tidy if required.",vbInformation,title
      End If
      OP=FSO.GetParentFolderName(OldPath)
      NP=FSO.GetParentFolderName(NewPath)
      ' See if parent folders no longer contain media or subfolders, move art if needed, then delete
      MoveArt OP,NP
      ' Promote or remove promoted art if required
      If NF.ParentFolder.SubFolders.Count=1 Then
        ' Only one album subfolder for artist, promote thumbnail if possible
        If FSO.FileExists(NP & "\Folder.jpg")=False Then
          If FSO.FileExists(NewPath & "\Folder.jpg") And Thumbs Then
            FSO.CopyFile NewPath & "\Folder.jpg",NP & "\"
          End If
        End If
      Else
        ' More than one album subfolder for artist, remove thumbnail in artist folder if it exists and is not read-only
        If FSO.FileExists(NP & "\Folder.jpg") Then
          Set F=FSO.GetFile(NP & "\Folder.jpg")
          If (F.Attributes AND 1)=0 Then F.Delete
	      End If
      End If
    End If
  End If
End Sub


' Custom prompt for track-by-track confirmation
' Modified 2016-03-15
Function Prompt(T)
  Dim W
  With T
    If Switch Then W="link" Else W="file"
    If Export Then
      Prompt="Copy file from:" & nl & FSO.GetAbsolutePathName(.Location) & nl & "to:" & nl & NewPath & " ?"
    ElseIf FSO.GetAbsolutePathName(.Location)<>NewPath Then
      Prompt="Move " & W & " from:" & nl & FSO.GetAbsolutePathName(.Location) & nl & "to:" & nl & NewPath & " ?"
    Else 
      Prompt="Move " & W & " from:" & nl & .Location & nl & "to:" & nl & FSO.GetAbsolutePathName(.Location) & " ?"
    End If
  End With
End Function


' Recycled from http://gallery.technet.microsoft.com/scriptcenter/191eb207-3a7e-4dbc-884d-5f4498440574
' Modified to recursively remove any emptied folders. Rewritten to simplify and use global objects/declarations
' Needs FSO,Reg,SH objects. If UseTrash is false delete directly without attempting to recycle.

' Send file or folder to recycle bin, return status
' Modified 2014-05-05
Function Recycle(FilePath)
  Const HKEY_CURRENT_USER=&H80000001 
  Const KeyPath="Software\Microsoft\Windows\CurrentVersion\Explorer" 
  Const KeyName="ShellState" 
  Dim File,FileName,Folder,FolderName,I,Parent,State,V,Value,Verb
  Recycle=False
  If Not(FSO.FileExists(FilePath) Or FSO.FolderExists(FilePath)) Then Exit Function     ' Can't delete something that isn't there
  If  UseTrash Then
    ' Make sure recycle bin properties are set to NOT display request for delete confirmation 
    Reg.GetBinaryValue HKEY_CURRENT_USER,KeyPath,KeyName,Value			' Get current shell state 
    State=Value(4)	 							' Preserve current option
    Value(4)=39									  ' Set new option 
    Reg.SetBinaryValue HKEY_CURRENT_USER,KeyPath,KeyName,Value			' Update shell state
   
    ' Use the Shell to send the file to the recycle bin 
    FileName=FSO.GetFileName(FilePath)
    FolderName=FSO.GetParentFolderName(FilePath)
    Set Folder=SH.NameSpace(FolderName)
    Set File=Folder.ParseName(FileName)

    If Not File Is Nothing Then  
      'File.InvokeVerb("&Delete")	' Delete file, sending to recycle bin - fails for Vista/Windows 7
      I=File.Verbs.Count          ' Use DoIt instead of InvokeVerb - http://forums.wincustomize.com/322016
      Do
        I=I-1
        Verb="|" & LCase(File.Verbs.Item(I).Name) & "|"
        V=Instr(Verb,"&")
        If V>0 Then Verb=Left(Verb,V-1) & Mid(Verb,V+1)
        ' Add lower case localised words for delete here, separated by |
        If Instr("|delete|verwijderen|",Verb) Then
          File.Verbs.Item(I).DoIt()
          Exit Do
        End If
      Loop Until I=0
    End If
  Else    ' Delete via FSO instead of Shell
    'Trace Null,"Deleting " & FilePath
    FolderName=FSO.GetParentFolderName(FilePath)
    FSO.DeleteFile FilePath,True
  End If
  If FSO.FileExists(FilePath) Then
    MsgBox "There was a problem deleting the file:" & nl & FilePath,vbCritical,Title
  Else
    Recycle=True
    ' Delete folder using FileSystem if now empty, repeat for parent folders
    Set Folder=FSO.GetFolder(FolderName)
    While Folder.Files.Count=0 And Folder.SubFolders.Count=0
      Set Parent=Folder.ParentFolder
      Folder.Delete
      Set Folder=Parent
    Wend
  End If

  If UseTrash Then
    ' Restore the user's property settings for the Recycle Bin 
    Value(4)=State								' Restore option
    Reg.SetBinaryValue HKEY_CURRENT_USER,KeyPath,KeyName,Value			' Update shell state
  End If

End Function


' Remove folder even if marked as Read only
' Modified 2011-09-17
Sub RmDir(F)
  On Error Resume Next
  FSO.DeleteFolder F, True
  If FSO.FolderExists(F) Then MsgBox "There was a problem deleing the folder" & nl & F & nl & nl & "Please delete by hand, probably after rebooting.",0,Title
End Sub


' Return iTunes like sort name
' Modified 2011-01-27
Function SortName(N)
  Dim L
  N=LTrim(N)
  L=LCase(N)
  SortName=N
  If Left(L,2)="a " Then SortName=Mid(N,3)
  If Left(L,3)="an " Then SortName=Mid(N,4)
  If Left(L,3)="""a " Then SortName=Mid(N,4)
  If Left(L,4)="the " Then SortName=Mid(N,5)
  If Left(L,4)="""an " Then SortName=Mid(N,5)
  If Left(L,5)="""the " Then SortName=Mid(N,6)
End Function


' Custom status message for progress bar
' Modified 2011-10-21
Function Status(N)
  Status="Processing " & N & " of " & Count
End Function


' Creates valid folder names but moves and leading "The " to the end of the string so folder
' order matches iTunes sorting (more or less) while still showing the full title.
' Originally I used to do this manually just for artists but now apply it to albums as well.
' Modified 2011-09-17
Function TheValidFolder(N)
  If Left(N,4)="The " Then
    TheValidFolder=ValidFolder(Mid(N,5) & ", The")
  Else
    TheValidFolder=ValidFolder(N)
  End If
End Function 


' Custom trace messages for troubleshooting, T is the current track if needed 
' Modified 2014-05-04
Sub Trace(T,M)
  If Tracing Then
    Dim R,Q
    Q=Info(T) & nl & nl & M & nl & nl
    Q=Q & "Yes" & tab & ": Continue tracing" & nl
    Q=Q & "No" & tab & ": Skip further tracing" & nl
    Q=Q & "Cancel" & tab & ": Abort script"
    R=MsgBox(Q,vbYesNoCancel,Title)
    If R=vbCancel Then WScript.Quit
    If R=vbNo Then Tracing=False
  End If
End Sub


' Test for tracks which can be usefully updated
' Modified 2016-03-04
Function Updateable(T)
  Dim Ext,L,ID
  ID=PersistentID(T)
  Updateable=False
  If IDs.Exists(ID) Then                ' Ignore tracks already processed
    D=D+1                               ' Increment duplicate tracks
  Else
    IDs.Add ID,0                        ' Note ID to prevent reprocessing this track
    If T.Location="" Then               ' Missing files can't be processed by this script
      M=M+1                             ' Increment missing tracks
      If Prog Then PB.SetDebug "<br>Missing file!" : WScript.Sleep 500
    Else                                ' Update files that are not where they should be
      If Switch Then
        If Instr(T.Location,OldRoot)=1 Then Updateable=FSO.FileExists(FilenameFromTag(T)) : If Updateable=False Then M=M+1 : Exit Function
      ElseIf Export Then
        Ext=LCase(Mid(T.Location,InStrRev(T.Location,".")))
        If Instr(".epub.ibooks.ipa.ipg.ite.itlp.mid.pdf",Ext)=0 Then Updateable=Not FSO.FileExists(FilenameFromTag(T)) 
      Else
        L=FSO.GetAbsolutePathName(T.Location) : If LCase(Left(L,Len(Root)))=LCase(Root) Then L=Root & Mid(L,Len(Root)+1)
        Updateable=L<>FilenameFromTag(T) Or L<>T.Location
      End If  
      If Not Updateable Then V=V+1      ' Increment unchanging tracks
    End If
  End If
End Function


' Replace invalid filename characters: \ / : * ? " < > | per http://support.microsoft.com/kb/177506
' Strip leading/trailing spaces & leading periods, trailing periods allowed
' Modified 2011-12-01
Function ValidFile(N)
  N=Replace(N,"\","-")
  N=Replace(N,"/","-")
  N=Replace(N,":",";")
  N=Replace(N,"*","-")
  N=Replace(N,"?","")
  N=Replace(N,"""","''")
  N=Replace(N,"<","{")
  N=Replace(N,">","}")
  N=Replace(N,"|","!")
  Do While Left(N,1)=" " Or Left(N,1)="." Or Left(N,1)="-"
    N=Mid(N,2)
    If N=" " Or N="." Then N="_" ' Prevent name from vanishing
  Loop 
  Do While Right(N,1)=" "
    N=Left(N,Len(N)-1)
  Loop 
  ValidFile=N
End Function


' Folder naming rules as for files except trailing periods not allowed
' Modified 2011-09-17
Function ValidFolder(N)
  N=ValidFile(N)
  Do While Right(N,1)="."
    N=Left(N,Len(N)-1)
  Loop 
  ValidFolder=N
End Function


' Replace invalid filename characters: \ / : * ? " < > | and also ;
' Replace leading space or period, strip trailing spaces, trailing periods allowed
' Limit to 40 characters inclusive of extension. No trailing period for folder name 
' Modified 2011-09-17
Function ValidiTunes(N,E)
  N=Left(N,40-Len(E))
  N=Replace(N,"\","_")
  N=Replace(N,"/","_")
  N=Replace(N,":","_")
  N=Replace(N,"*","_")
  N=Replace(N,"?","_")
  N=Replace(N,"""","_")
  N=Replace(N,"<","_")
  N=Replace(N,">","_")
  N=Replace(N,"|","_")
  N=Replace(N,";","_")
  Do While Right(N,1)=" "
    N=Left(N,Len(N)-1)
  Loop
  If Left(N,1)=" " Or Left(N,1)="." Then N="_" & Mid(N,2)
  If E="" And Right(N,1)="." Then N=Left(N,Len(N)-1) & "_"
  ValidiTunes=N
End Function


' Clean any invalid characters from a file path
' Modified 2016-02-29
Function ValidPath(N)
  Dim P
  If Mid(N,2,1)=":" Then
    ValidPath=Left(N,2) & ValidPath(Mid(N,3))
  Else
    P=Instr(N,"\")
    If P>0 Then
      ValidPath=ValidFolder(Left(N,P-1)) & "\" & ValidPath(Mid(N,P+1))
    Else
      ValidPath=ValidFile(N)
    End If
  End If
End Function


' ============================================
' Reusable Library Routines for iTunes Scripts
' ============================================
' Modified 2014-10-07


' Return lower case file extension with leading . or empty string if no extension
' Modified 2014-06-29
Function Ext(Path)
  Ext=LCase(FSO.GetExtensionName(Path))
  If Ext<>"" Then Ext="." & Ext
End Function


' Format time interval from x.xxx seconds to hh:mm:ss
' Modified 2011-11-07
Function FormatTime(T)
  If T<0 Then T=T+86400         ' Watch for timer running over midnight
  If T<2 Then
    FormatTime=FormatNumber(T,3) & " seconds"
  ElseIf T<10 Then
    FormatTime=FormatNumber(T,2) & " seconds"
  ElseIf T<60 Then
    FormatTime=Int(T) & " seconds"
  Else
    Dim H,M,S
    S=T Mod 60
    M=(T\60) Mod 60             ' \ = Div operator for integer division
    'S=Right("0" & (T Mod 60),2)
    'M=Right("0" & ((T\60) Mod 60),2)  ' \ = Div operator for integer division
    H=T\3600
    If H>0 Then
      FormatTime=H & Plural(H," hours "," hour ") & M & Plural(M," mins"," min")
      'FormatTime=H & ":" & M & ":" & S
    Else
      FormatTime=M & Plural(M," mins "," min ") & S & Plural(S," secs"," sec")
      'FormatTime=M & " :" & S
      'If Left(FormatTime,1)="0" Then FormatTime=Mid(FormatTime,2)
    End If
  End If
End Function


' Initialise track selections, quit script if track selection is out of bounds or user aborts
' Modified 2016-03-15
Sub GetTracks
  Dim Q,R
  ' Initialise global variables
  nl=vbCrLf : tab=Chr(9) : Quit=False
  D=0 : M=0 : P=0 : S=0 : U=0 : V=0
  ' Initialise global objects
  Set IDs=CreateObject("Scripting.Dictionary")
  Set iTunes=CreateObject("iTunes.Application")
  Set Tracks=iTunes.SelectedTracks      ' Get current selection
  If iTunes.BrowserWindow.SelectedPlaylist.Source.Kind<>1 And Source="" Then Source="Library" : Named=True      ' Ensure section is from the library source
  'If iTunes.BrowserWindow.SelectedPlaylist.Name="Ringtones" And Source="" Then Source="Library" : Named=True    ' and not ringtones (which cannot be processed as tracks???)
  If iTunes.BrowserWindow.SelectedPlaylist.Name="Radio" And Source="" Then Source="Library" : Named=True        ' or radio stations (which cannot be processed as tracks)
  If iTunes.BrowserWindow.SelectedPlaylist.Name=Playlist And Source="" Then Source="Library" : Named=True       ' or a playlist that will be regenerated by this script
  If Named Or Tracks Is Nothing Then    ' or use a named playlist
    If Source<>"" Then Named=True
    If Source="Library" Then            ' Get library playlist...
      Set Tracks=iTunes.LibraryPlaylist.Tracks
    Else                                ' or named playlist
      On Error Resume Next              ' Attempt to fall back to current selection for non-existent source
      Set Tracks=iTunes.LibrarySource.Playlists.ItemByName(Source).Tracks
      On Error Goto 0
      If Tracks is Nothing Then         ' Fall back
        Named=False
        Source=iTunes.BrowserWindow.SelectedPlaylist.Name
        Set Tracks=iTunes.SelectedTracks
        If Tracks is Nothing Then
          Set Tracks=iTunes.BrowserWindow.SelectedPlaylist.Tracks
        End If
      End If
    End If
  End If  
  If Named And Tracks.Count=0 Then      ' Quit if no tracks in named source
    If Intro Then MsgBox "The playlist " & Source & " is empty, there is nothing to do.",vbExclamation,Title
    WScript.Quit
  End If
  If Tracks.Count=0 Then Set Tracks=iTunes.LibraryPlaylist.Tracks
  If Tracks.Count=0 Then                ' Can't select ringtones as tracks?
    MsgBox "This script cannot process " & iTunes.BrowserWindow.SelectedPlaylist.Name & ".",vbExclamation,Title
    WScript.Quit
  End If
  ' Check there is a suitable number of suitable tracks to work with
  Count=Tracks.Count
  If Count<Min Or (Count>Max And Max>0) Then
    If Max=0 Then
      MsgBox "Please select " & Min & " or more tracks in iTunes before calling this script!",0,Title
      WScript.Quit
    Else
      MsgBox "Please select between " & Min & " and " & Max & " tracks in iTunes before calling this script!",0,Title
      WScript.Quit
    End If
  End If
  ' Check if the user wants to proceed and how
  Q=Summary
  If Q<>"" Then Q=Q & nl & nl
  If Warn>0 And Count>Warn Then
    Intro=True
    Q=Q & "WARNING!" & nl & "Are you sure you want to process " & GroupDig(Count) & " tracks"
    If Named Then Q=Q & nl
  Else
    Q=Q & "Process " & GroupDig(Count) & " track" & Plural(Count,"s","")
  End If
  If Named Then Q=Q & " from the " & Source & " playlist"
  Q=Q & "?"
  If Intro Or (Prog And UAC) Then
    If Check Then
      Q=Q & nl & nl 
      Q=Q & "Yes" & tab & ": Process track" & Plural(Count,"s","") & " automatically" & nl
      Q=Q & "No" & tab & ": Preview & confirm each action" & nl
      Q=Q & "Cancel" & tab & ": Abort script"
    End If
    If Kimo Then Q=Q & nl & nl & "NB: Disable ""Keep iTunes Media folder organised"" preference."
    If Prog And UAC Then
      Q=Q & nl & nl & "NB: Use the EnableLUA script to allow the progress bar to function" & nl
      Q=Q & "or change the declaration ''Prog=True'' to ''Prog=False'' to hide this message. "
      Prog=False
    End If
    If Check Then
      R=MsgBox(Q,vbYesNoCancel+vbQuestion,Title)
    Else
      R=MsgBox(Q,vbOKCancel+vbQuestion,Title)
    End If
    If R=vbCancel Then WScript.Quit
    If R=vbYes or R=vbOK Then
      Check=False
    Else
      Check=True
    End If
  End If 
  If Check Then Prog=False      ' Suppress progress bar if prompting for user input
End Sub


' Group digits and separate with commas
' Modified 2014-04-29
Function GroupDig(N)
  GroupDig=FormatNumber(N,0,-1,0,-1)
End Function


' Return the persistent object representing the track from its ID as a string
' Modified 2014-09-26 - CLng works better than Eval 
Function ObjectFromID(ID)
  Set ObjectFromID=iTunes.LibraryPlaylist.Tracks.ItemByPersistentID(CLng("&H" & Left(ID,8)),CLng("&H" & Right(ID,8)))
End Function


' Create a string representing the 64 bit persistent ID of an iTunes object
' Modified 2012-08-24
Function PersistentID(T)
  PersistentID=Right("0000000" & Hex(iTunes.ITObjectPersistentIDHigh(T)),8) & "-" & Right("0000000" & Hex(iTunes.ITObjectPersistentIDLow(T)),8)
End Function


' Return the persistent object representing the track
' Keeps hold of an object that might vanish from a smart playlist as it is updated
' Modified 2014-05-15
Function PersistentObject(T)
  Dim Ext,L
  Set PersistentObject=T
  On Error Resume Next  ' Trap possible error
  L=T.Location
  If Err.Number<>0 Then
    Trace T,"Error reading location property from object."
  ElseIf L<>"" Then
    Ext=LCase(Right(L,4))
    If Instr(".ipa.ipg.m4r",Ext)=0 Then         ' Method below fails for apps, games & ringtones
      Set PersistentObject=iTunes.LibraryPlaylist.Tracks.ItemByPersistentID(iTunes.ITObjectPersistentIDHigh(T),iTunes.ITObjectPersistentIDLow(T))
    End If  
  End If  
End Function


' Return relevant string depending on whether value is plural or singular
' Modified 2011-10-04
Function Plural(V,P,S)
  If V=1 Then Plural=S Else Plural=P
End Function


' Format a list of values for output
' Modified 2012-08-25
Function PrettyList(L,N)
  If L="" Then
    PrettyList=N & "."
  Else
    PrettyList=Replace(Left(L,Len(L)-1)," and" & nl,"," & nl) & " and" & nl & N & "."
  End If
End Function


' Loop through track selection processing suitable items
' Modified 2014-04-29
Sub ProcessTracks
  Dim C,I,N,Q,R,T
  Dim First,Last,Steps
  If IsEmpty(Rev) Then Rev=True
  If Rev Then
    First=Count : Last=1 : Steps=-1
  Else
    First=1 : Last=Count : Steps=1
  End If
  N=0
  If Prog Then                  ' Create ProgessBar
    Set PB=New ProgBar
    PB.SetTitle Title
    PB.Show
  End If
  Clock=0 : StartTimer
  For I=First To Last Step Steps        ' Usually work backwards in case edit removes item from selection
    N=N+1                 
    If Prog Then
      PB.SetStatus Status(N)
      PB.Progress N-1,Count
    End If
    Set T=Tracks.Item(I)
    Set T=PersistentObject(T)   ' Attach to object in library playlist
    If Prog Then PB.SetInfo Info(T)
    If T.Kind=1 Then            ' Ignore tracks which can't change
      If Updateable(T) Then     ' Ignore tracks which won't change
        If Check Then           ' Track by track confirmation
          Q=Prompt(T)
          StopTimer             ' Don't time user inputs 
          R=MsgBox(Q,vbYesNoCancel+vbQuestion,Title & " - " & GroupDig(N) & " of " & GroupDig(Count))
          StartTimer
          Select Case R
          Case vbYes
            C=True
          Case vbNo
            C=False
            S=S+1               ' Increment skipped tracks
          Case Else
            Quit=True
            Exit For
          End Select          
        Else
          C=True
        End If
        If C Then               ' We have a valid track, now do something with it
          Action T
        End If
      End If
    End If 
    P=P+1                       ' Increment processed tracks
    If Quit Then Exit For       ' Abort loop on user request
  Next
  StopTimer
  If Prog And Not Quit Then
    PB.Progress Count,Count
    WScript.Sleep 250
  End If
  If Prog Then PB.Close
End Sub


' Output report
' Modified 2016-02-29
Sub Report
  If Not Outro Then Exit Sub
  Dim L,T,W1,W2
  If Export Then
    W1="exporting":W2="exported"
  Else
    W1="updating":W2="updated"
  End If
  L=""
  If Quit Then T="Script aborted!" & nl & nl Else T=""
  T=T & GroupDig(P) & " track" & Plural(P,"s","")
  If P<Count Then T=T & " of " & GroupDig(Count)
  T=T & Plural(P," were"," was") & " processed of which " & nl
  If D>0 Then L=PrettyList(L,GroupDig(D) & Plural(D," were duplicates"," was a duplicate") & " in the list")
  If V>0 Then L=PrettyList(L,GroupDig(V) & " did not need " & W1)
  If U>0 Or V=0 Then L=PrettyList(L,GroupDig(U) & Plural(U," were "," was ") & W2)
  If S>0 Then L=PrettyList(L,GroupDig(S) & Plural(S," were"," was") & " skipped")
  If M>0 Then L=PrettyList(L,GroupDig(M) & Plural(M," were"," was") & " missing")
  T=T & L
  If Timing Then 
    T=T & nl & nl
    If Check Then T=T & "Processing" Else T=T & "Running"
    T=T & " time: " & FormatTime(Clock)
  End If
  MsgBox T,vbInformation,Title
End Sub


' Return iTunes like sort name
' Modified 2011-01-27
Function SortName(N)
  Dim L
  N=LTrim(N)
  L=LCase(N)
  SortName=N
  If Left(L,2)="a " Then SortName=Mid(N,3)
  If Left(L,3)="an " Then SortName=Mid(N,4)
  If Left(L,3)="""a " Then SortName=Mid(N,4)
  If Left(L,4)="the " Then SortName=Mid(N,5)
  If Left(L,4)="""an " Then SortName=Mid(N,5)
  If Left(L,5)="""the " Then SortName=Mid(N,6)
End Function


' Start timing event
' Modified 2011-10-08
Sub StartEvent
  T2=Timer
End Sub


' Start timing session
' Modified 2011-10-08
Sub StartTimer
  T1=Timer
End Sub


' Stop timing event and display elapsed time in debug section of Progress Bar
' Modified 2011-11-07
Sub StopEvent
  If Prog Then
    T2=Timer-T2
    If T2<0 Then T2=T2+86400            ' Watch for timer running over midnight
    If Debug Then PB.SetDebug "<br>Last iTunes call took " & FormatTime(T2) 
  End If  
End Sub


' Stop timing session and add elapased time to running clock
' Modified 2011-10-08
Sub StopTimer
  Clock=Clock+Timer-T1
  If Clock<0 Then Clock=Clock+86400     ' Watch for timer running over midnight
End Sub


' Detect if User Access Control is enabled, UAC (or rather LUA) prevents use of progress bar
' Modified 2011-10-18
Function UAC
  Const HKEY_LOCAL_MACHINE=&H80000002
  Const KeyPath="Software\Microsoft\Windows\CurrentVersion\Policies\System"
  Const KeyName="EnableLUA"
  Dim Reg,Value
  Set Reg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") 	  ' Use . for local computer, otherwise could be computer name or IP address
  Reg.GetDWORDValue HKEY_LOCAL_MACHINE,KeyPath,KeyName,Value	  ' Get current property
  If IsNull(Value) Then UAC=False Else UAC=(Value<>0)
End Function


' Wrap & tab long strings, break string S after character C working back from up to W characters adding T tabs to each new line
' Modified 2014-09-27
Function Wrap(S,W,C,T)
  Dim P
  If Len(S)<=W Then
    Wrap=S
  Else    
    P=InstrRev(S,C,W)
    If P Then Wrap=Left(S,P) & nl & String(T,tab) & Wrap(Mid(S,P+1),W,C,T)
  End If
End Function


' ==================
' Progress Bar Class
' ==================

' Progress/activity bar for vbScript implemented via IE automation
' Can optionally rebuild itself if closed or abort the calling script
' Modified 2014-05-04
Class ProgBar
  Public Cells,Height,Width,Respawn,Title,Version
  Private Active,Blank,Dbg,Filled(),FSO,IE,Info,NextOn,NextOff,Status,SHeight,SWidth,Temp

' User has closed progress bar, abort or respwan?
' Modified 2011-10-09
  Public Sub Cancel()
    If Respawn And Active Then
      Active=False
      If Respawn=1 Then
        Show                    ' Ignore user's attempt to close and respawn
      Else
        Dim R
        StopTimer               ' Don't time user inputs 
        R=MsgBox("Abort Script?",vbExclamation+vbYesNoCancel,Title)
        StartTimer
        If R=vbYes Then
          On Error Resume Next
          CleanUp
          Respawn=False
          Quit=True             ' Global flag allows main program to complete current task before exiting
        Else
          Show                  ' Recreate box if closed
        End If  
      End If        
    End If
  End Sub

' Delete temporary html file  
' Modified 2011-10-04
  Private Sub CleanUp()
    FSO.DeleteFile Temp         ' Delete temporary file
  End Sub
  
' Close progress bar and tidy up
' Modified 2011-10-04
  Public Sub Close()
    On Error Resume Next        ' Ignore errors caused by closed object
    If Active Then
      Active=False              ' Ignores second call as IE object is destroyed
      IE.Quit                   ' Remove the progess bar
      CleanUp
    End If    
 End Sub
 
' Initialize object properties
' Modified 2012-09-05
  Private Sub Class_Initialize()
    Dim I,Items,strComputer,WMI
    ' Get width & height of screen for centering ProgressBar
    strComputer="."
    Set WMI=GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Set Items=WMI.ExecQuery("Select * from Win32_OperatingSystem",,48)
    'Get the OS version number (first two)
    For Each I in Items
      Version=Left(I.Version,3)
    Next
    Set Items=WMI.ExecQuery ("Select * From Win32_DisplayConfiguration")
    For Each I in Items
      SHeight=I.PelsHeight
      SWidth=I.PelsWidth
    Next
    If Debug Then
      Height=160                ' Height of containing div
    Else
      Height=120                ' Reduce height if no debug area
    End If
    Width=300                   ' Width of containing div
    Respawn=True                ' ProgressBar will attempt to resurect if closed
    Blank=String(50,160)        ' Blanks out "Internet Explorer" from title
    Cells=25                    ' No. of units in ProgressBar, resize window if using more cells
    ReDim Filled(Cells)         ' Array holds current state of each cell
    For I=0 To Cells-1
      Filled(I)=False
    Next
    NextOn=0                    ' Next cell to be filled if busy cycling
    NextOff=Cells-5             ' Next cell to be cleared if busy cycling
    Dbg="&nbsp;"                ' Initital value for debug text
    Info="&nbsp;"               ' Initital value for info text
    Status="&nbsp;"             ' Initital value for status text
    Title="Progress Bar"        ' Initital value for title text
    Set FSO=CreateObject("Scripting.FileSystemObject")          ' File System Object
    Temp=FSO.GetSpecialFolder(2) & "\ProgBar.htm"               ' Path to Temp file
  End Sub

' Tidy up if progress bar object is destroyed
' Modified 2011-10-04
  Private Sub Class_Terminate()
    Close
  End Sub
 
' Display the bar filled in proportion X of Y
' Modified 2011-10-18
  Public Sub Progress(X,Y)
    Dim F,I,L,S,Z
    If X<0 Or X>Y Or Y<=0 Then
      MsgBox "Invalid call to ProgessBar.Progress, variables out of range!",vbExclamation,Title
      Exit Sub
    End If
    Z=Int(X/Y*(Cells))
    If Z=NextOn Then Exit Sub
    If Z=NextOn+1 Then
      Step False
    Else
      If Z>NextOn Then
        F=0 : L=Cells-1 : S=1
      Else
        F=Cells-1 : L=0 : S=-1
      End If
      For I=F To L Step S
        If I>=Z Then
          SetCell I,False
        Else
          SetCell I,True
        End If
      Next
      NextOn=Z
    End If
  End Sub

' Clear progress bar ready for reuse  
' Modified 2011-10-16
  Public Sub Reset
    Dim C
    For C=Cells-1 To 0 Step -1
      IE.Document.All.Item("P",C).classname="empty"
      Filled(C)=False
    Next
    NextOn=0
    NextOff=Cells-5   
  End Sub
  
' Directly set or clear a cell
' Modified 2011-10-16
  Public Sub SetCell(C,F)
    On Error Resume Next        ' Ignore errors caused by closed object
    If F And Not Filled(C) Then
      Filled(C)=True
      IE.Document.All.Item("P",C).classname="filled"
    ElseIf Not F And Filled(C) Then
      Filled(C)=False
      IE.Document.All.Item("P",C).classname="empty"
    End If
  End Sub 
 
' Set text in the Dbg area
' Modified 2011-10-04
  Public Sub SetDebug(T)
    On Error Resume Next        ' Ignore errors caused by closed object
    Dbg=T
    IE.Document.GetElementById("Debug").InnerHTML=T
  End Sub

' Set text in the info area
' Modified 2011-10-04
  Public Sub SetInfo(T)
    On Error Resume Next        ' Ignore errors caused by closed object
    Info=T
    IE.Document.GetElementById("Info").InnerHTML=T
  End Sub

' Set text in the status area
' Modified 2011-10-04
  Public Sub SetStatus(T)
    On Error Resume Next        ' Ignore errors caused by closed object
    Status=T
    IE.Document.GetElementById("Status").InnerHTML=T
  End Sub

' Set title text
' Modified 2011-10-04
  Public Sub SetTitle(T)
    On Error Resume Next        ' Ignore errors caused by closed object
    Title=T
    IE.Document.Title=T & Blank
  End Sub
  
' Create and display the progress bar  
' Modified 2014-05-04
  Public Sub Show()
    Const HKEY_CURRENT_USER=&H80000001
    Const KeyPath="Software\Microsoft\Internet Explorer\Main\FeatureControl\FEATURE_LOCALMACHINE_LOCKDOWN"
    Const KeyName="iexplore.exe"
    Dim File,I,Reg,State,Value
    Set Reg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") 	' Use . for local computer, otherwise could be computer name or IP address
    'On Error Resume Next        ' Ignore possible errors
    ' Make sure IE is set to allow local content, at least while we get the Progress Bar displayed
    Reg.GetDWORDValue HKEY_CURRENT_USER,KeyPath,KeyName,Value	' Get current property
    State=Value	 							  ' Preserve current option
    Value=0		    							' Set new option 
    Reg.SetDWORDValue HKEY_CURRENT_USER,KeyPath,KeyName,Value	' Update property
    'If Version<>"5.1" Then Prog=False : Exit Sub      ' Need to test for Vista/Windows 7 with UAC
    Set IE=WScript.CreateObject("InternetExplorer.Application","Event_")
    Set File=FSO.CreateTextFile(Temp, True)
    With File
      .WriteLine "<!doctype html>"
      '.WriteLine "<!-- saved from url=(0014)about:internet -->"
      .WriteLine "<!-- saved from url=(0016)http://localhost -->"      ' New "Mark of the web"
      .WriteLine "<html><head><title>" & Title & Blank & "</title>"
      .WriteLine "<style type='text/css'>"
      .WriteLine ".border {border: 5px solid #DBD7C7;}"
      .WriteLine ".debug {font-family: Tahoma; font-size: 8.5pt;}"
      .WriteLine ".empty {border: 2px solid #FFFFFF; background-color: #FFFFFF;}"
      .WriteLine ".filled {border: 2px solid #FFFFFF; background-color: #00FF00;}"
      .WriteLine ".info {font-family: Tahoma; font-size: 8.5pt;}"
      .WriteLine ".status {font-family: Tahoma; font-size: 10pt;}"
      .WriteLine "</style>"
      .WriteLine "</head>"
      .WriteLine "<body scroll='no' style='background-color: #EBE7D7'>"
      .WriteLine "<div style='display:block; height:" & Height & "px; width:" & Width & "px; overflow:hidden;'>"
      .WriteLine "<table border-width='0' cellpadding='2' width='" & Width & "px'><tr>"
      .WriteLine "<td id='Status' class='status'>" & Status & "</td></tr></table>"
      .WriteLine "<table class='border' cellpadding='0' cellspacing='0' width='" & Width & "px'><tr>"
      ' Write out cells
      For I=0 To Cells-1
	      If Filled(I) Then
          .WriteLine "<td id='p' class='filled'>&nbsp;</td>"
        Else
          .WriteLine "<td id='p' class='empty'>&nbsp;</td>"
        End If
      Next
	    .WriteLine "</tr></table>"
      .WriteLine "<table border-width='0' cellpadding='2' width='" & Width & "px'><tr><td>"
      .WriteLine "<span id='Info' class='info'>" & Info & "</span><br>"
      .WriteLine "<span id='Debug' class='debug'>" & Dbg & "</span></td></tr></table>"
      .WriteLine "</div></body></html>"
    End With
    ' Create IE automation object with generated HTML
    With IE
      .width=Width+35           ' Increase if using more cells
      .height=Height+60         ' Increase to allow more info/debug text
      If Version>"5.1" Then     ' Allow for bigger border in Vista/Widows 7
        .width=.width+10
        .height=.height+10
      End If        
      .left=(SWidth-.width)/2
      .top=(SHeight-.height)/2
      .navigate "file://" & Temp
      '.navigate "http://samsoft.org.uk/progbar.htm"
      .addressbar=False
      .resizable=False
      .toolbar=False
      On Error Resume Next      
      .menubar=False            ' Causes error in Windows 8 ? 
      .statusbar=False          ' Causes error in Windows 7 or IE 9
      On Error Goto 0
      .visible=True             ' Causes error if UAC is active
    End With
    Active=True
    ' Restore the user's property settings for the registry key
    Value=State		    					' Restore option
    Reg.SetDWORDValue HKEY_CURRENT_USER,KeyPath,KeyName,Value	  ' Update property 
    Exit Sub
  End Sub
 
' Increment progress bar, optionally clearing a previous cell if working as an activity bar
' Modified 2011-10-05
  Public Sub Step(Clear)
    SetCell NextOn,True : NextOn=(NextOn+1) Mod Cells
    If Clear Then SetCell NextOff,False : NextOff=(NextOff+1) Mod Cells
  End Sub

' Self-timed shutdown
' Modified 2011-10-05 
  Public Sub TimeOut(S)
    Dim I
    Respawn=False                ' Allow uninterrupted exit during countdown
    For I=S To 2 Step -1
      SetDebug "<br>Closing in " & I & " seconds" & String(I,".")
      WScript.sleep 1000
    Next
      SetDebug "<br>Closing in 1 second."
      WScript.sleep 1000
    Close
  End Sub 
    
End Class


' Fires if progress bar window is closed, can't seem to wrap up the handler in the class
' Modified 2011-10-04
Sub Event_OnQuit()
  PB.Cancel
End Sub


' ==============
' End of listing
' ==============