' ============== ' ExportToFolder ' ============== ' Version 1.0.3.16 - May 10th 2021 ' Copyright © Steve MacGuire 2010-2021 ' http://samsoft.org.uk/iTunes/ExportToFolder.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 . ' 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 ' Version 1.0.3.16 - Fix for album or artist names ending in " ..." and better handling of blank AlbumArtist, Aritst, or Album values when exporting ' ========== ' 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\\\ " ' 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 2021-05-10 Function FilenameFromTag(Track) Dim C,F,K,R,T,Ext,NewFolder,NewName,OldAlbum,OldFolder,OldName,Seq,SortArtist,ValidAlbum,ValidAlbumArtist,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: ,,,,,,,,,, ValidAlbum=.Album & "" ' N.b. adding "" prevents null value errors If ValidAlbum="" Then ValidAlbum="Unknown Album" ValidAlbumArtist=.AlbumArtist & "" If ValidAlbumArtist="" Then ValidAlbumArtist=.Artist & "" If ValidAlbumArtist="" Then ValidAlbumArtist="Unknown Artist" ValidArtist=.Artist & "" If ValidArtist="" Then ValidArtist="Unknown Artist" K=Root & Pattern & Ext K=Replace(K,"",ValidAlbum,1,-1,1) K=Replace(K,"",ValidAlbumArtist,1,-1,1) K=Replace(K,"",ValidArtist,1,-1,1) K=Replace(K,"",.Composer,1,-1,1) K=Replace(K,"",.EpisodeID,1,-1,1) K=Replace(K,"",.Genre,1,-1,1) K=Replace(K,"",.Grouping,1,-1,1) K=Replace(K,"",.Name,1,-1,1) K=Replace(K,"",.Show,1,-1,1) K=Replace(K,"",.Year,1,-1,1) ' Pad out disc numbers to size of disc count If Instr(1,Pattern,"",1) Then C=Len(.DiscCount) Seq=Right(String(C,"0") & .DiscNumber,C) K=Replace(K,"",Seq,1,-1,1) End If ' Pad out index numbers to size of exported list If Instr(1,Pattern,"",1) Then C=Len(Count) If C<4 Then C=4 Seq=Right(String(C,"0") & U+1,C) K=Replace(K,"",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,"",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,"",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 2021-05-10 Sub GetPattern Dim Q If Pattern="" Then Pattern="\\ " 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,"") 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 "
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 (and spaces) not allowed ' Modified 2021-05-10 Function ValidFolder(N) N=ValidFile(N) Do While Right(N,1)="." or 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 CountMax 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 P0 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 "
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=" " ' Initital value for debug text Info=" " ' Initital value for info text Status=" " ' 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 "" '.WriteLine "" .WriteLine "" ' New "Mark of the web" .WriteLine "" & Title & Blank & "" .WriteLine "" .WriteLine "" .WriteLine "" .WriteLine "
" .WriteLine "" .WriteLine "
" & Status & "
" .WriteLine "" ' Write out cells For I=0 To Cells-1 If Filled(I) Then .WriteLine "" Else .WriteLine "" End If Next .WriteLine "
  
" .WriteLine "
" .WriteLine "" & Info & "
" .WriteLine "" & Dbg & "
" .WriteLine "
" 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 "
Closing in " & I & " seconds" & String(I,".") WScript.sleep 1000 Next SetDebug "
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 ' ==============