' ==========
' FindTracks
' ==========
' Version 1.0.1.45 - May 31st 2025
' Copyright � Steve MacGuire 2010-2025
' http://samsoft.org.uk/iTunes/FindTracks.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 find lost iTunes tracks

' =========
' ChangeLog
' =========
' Version 1.0.0.1 - Initial version
' Version 1.0.0.2 - Updated to new common code base with progress bar
' Version 1.0.0.3 - Added fuzzy matching with soundex coding
' Version 1.0.0.4 - Improvements to matching routines, selection from potential matches
' Version 1.0.0.5 - Minor bug fix
' Version 1.0.0.6 - Amendments to cope with searching potentially large Unknown Artist\Unknown Album folder
' Version 1.0.0.7 - Minor update to TV Show detection
' Version 1.0.0.8 - Updates to Action & GetMediaFolder to cope better with empty fields
' Version 1.0.0.9 - Multiple updates for exact size matching and deduping of search paths
' Version 1.0.1.1 - Minor update to prevent null value errors
' Version 1.0.1.2 - Add ability to find files in ## - <Artist> - <Name> form
' Version 1.0.1.3 - Updated common library functions
' Version 1.0.1.4 - Tweak to GetMediaPath
' Version 1.0.1.5 - Updates to common code
' Version 1.0.1.6 - Updated to search in Unknown Artist/Album, mislabelled album folders and CD# subfolders
' Version 1.0.1.7 - Updated to find "Matched AAC Audio file"
' Version 1.0.1.8 - Updates to audiobook search paths
' Version 1.0.1.9 - Updates to link automatically to files with small size discrepancy
' Version 1.0.1.10 - Tweak to previous update
' Version 1.0.1.11 - Fix bug in previous update when there is no valid match
' Version 1.0.1.12 - Bug hunting code added to Sub Action
' Version 1.0.1.13 - Updates to common code
' Version 1.0.1.14 - Correct minor typo
' Version 1.0.1.15 - Fix bug in FindFile routine
' Version 1.0.1.16 - Improved reporting for unknown media types
' Version 1.0.1.17 - Added ability to locate Audible .aa files
' Version 1.0.1.18 - Added ability to ignore multiple matches
' Version 1.0.1.19 - Added ability to ignore outsize matches, tweaks to prompts
' Version 1.0.1.20 - Look for files in <Media Folder>\<Genre>\<Artist>\<Album> layout
' Version 1.0.1.21 - Trap possible error when assigning new location, tweak common code to ignore streams & iCloud items
' Version 1.0.1.22 - Tweak error reporting
' Version 1.0.1.23 - Allow for folders in Last, First form
' Version 1.0.1.24 - Tweak list creating rules for edge case that added two copies of the same folder
' Version 1.0.1.25 - Avoid multiple matches on artist when searching for files in form <Artist> - <Name>.<Ext>
' Version 1.0.1.26 - Fix possible error in GetMediaPath when media folder is the root of a drive
' Version 1.0.1.27 - Update to GetMediaPath
' Version 1.0.1.28 - Patch to run with elevated permissions, search custom album folder, ignore undetected files
' Version 1.0.1.29 - Optional log file
' Version 1.0.1.30 - Support for WMA files? See https://discussions.apple.com/message/30248139#30248139
' Version 1.0.1.31 - Comment out elevation code, causes problems with Windows 10?
' Version 1.0.1.32 - Additional searches for personal layout
' Version 1.0.1.33 - Tweak for failed finds with Amazon naming
' Version 1.0.1.34 - Fix for genre subsearch with null values
' Version 1.0.1.35 - Feature to locate match in different format. See https://discussions.apple.com/thread/7775540
' Version 1.0.1.36 - Tweak to Soundex routine so that "&" matches with "and"
' Version 1.0.1.37 - Search for videos in \Show s1d1\Show-# form
' Version 1.0.1.38 - Find Apple Music files
' Version 1.0.1.39 - Improved options for multiple tracks
' Version 1.0.1.40 - Fix bug in GetRoot when no XML file
' Version 1.0.1.41 - Tweak options for <Artist> - <Title> layout
' Version 1.0.1.42 - Better behaviour for unknown Kind. See https://discussions.apple.com/thread/256007966?answerId=261326566022&sortBy=oldest_first#261326566022
' Version 1.0.1.43 - Tweaks to allow the repair of tracks with corrupt location property that holds the folder without filename & path
' Version 1.0.1.44 - Use known folder to begin search for tracks with corrupt location property
' Version 1.0.1.45 - Another attempt to finese things...



' ==========
' To-do List
' ==========
' Implement a fuzzy matching algorithm such as Soundex http://en.wikipedia.org/wiki/Soundex#Rules - Done
' Make sure script runs on Windows Vista/7 & IE 9 - Done
' Automatically choose between fuzzy matches on the basis of file size - Done

' =============================
' 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 2014-05-29
Const Kimo=True         ' True if script expects "Keep iTunes Media folder organised" to be disabled
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
Timing=True             ' Display running time in summary report
Named=False             ' Force script to process specific playlist rather than current selection or playlist
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

Title="Find Tracks"
Summary="Search for missing iTunes tracks within a target folder " & vbCrLF & "and reconnect to the library."

' Additional variables for this particular script
' Modified 2025-05-29
Dim Org                 ' Media organisation flag
Dim FSO                 ' Handle to FileSystemObject
Dim Root                ' Root of media library
Dim Check2              ' Alternate check flag for track by track confirmation
Dim SkipLost            ' Skip tracks that cannot be found automatically
Dim SkipMulti           ' Skip prompt when there is more than one potential match
Dim SkipOutsize         ' Skip/ignore when difference in file sizes is greater than limit
Dim FixOutsize          ' Fix without prompting when difference in file sizes is less than limit
Dim Limit               ' Number of bytes size difference for unprompted automatic matching
Dim CAL                 ' Custom Album name to add as a search target
Dim Logging,LogOpen     ' Manage logging options
Dim LogFile,LogPath     ' Manage logging options
Dim FindExt             ' Alternate extensions to try if no file with the expected extension is found
Dim MatchFirst          ' Take first match when the is more than one
Dim MoreInfo            ' More dialog boxes to reveal state of processing
Dim ArtistTitle         ' Option for alternate layout
Dim TestMode            ' Used when testing updates to the script to prevent new locations being assigned
Dim ShortMatch          ' Use when need to make shortend names fuzzy match. May increase mismatches.
Dim SwapAmp             ' Use when " and " may have been replaced by " & "
SwapAmp=False           ' Default false
ShortMatch=False        ' Default false
TestMode=False
MatchFirst=True
MoreInfo=False
ArtistTitle=False
SkipLost=False
SkipMulti=False
SkipOutsize=False
FixOutsize=True
'Limit=7000000          ' Default value is/was 20000 - Is this a good choice? E.g. compares well to size of artwork? - This feature needs work, ah may have temporarily broken passes 3/3.1
Limit=0                 ' Default value is/was 20000 - Is this a good choice? E.g. compares well to size of artwork? - This feature needs work, ah may have temporarily broken passes 3/3.1
Root=""
CAL=""                  ' Tweak for https://discussions.apple.com/message/29634402#29634402
Logging=False
LogOpen=False
FindExt=".m4a.mp3"      ' One or more file extensions in lowercase with leading period. E.g. ".mp3" or ".m4a.m4b", reverse priority 

If TestMode Then Title=Title & " (Test Mode)"

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

' Elevate               ' Ensure script runs with elevated permissions, may not work with Windows 10

GetTracks               ' Set things up
GetRoot                 ' More setup
ProcessTracks 	        ' Main process 
Report                  ' Summary
If Logging Then CloseLog

' ===================
' 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.


' Look for missing files and reconnect if found
' Dupes created by consolidation or giving two files the same details end " 1", " 2" etc.
' Dupes created by copying into Automatically add to iTunes folder (and ripping?) end " 2", " 3" etc.
' Modified 2025-05-29
Sub Action(Track)
  ' If Track.Location<>"" Then Exit Sub ' Rely on tests made in Updateable funtion
  Dim AltArtist,Best,C,Check1,Correct,Diff,Ext,F,Files,Folder,Genre,L,List,Name,NewPath,Pass,R,SF,Skip,T,TN,ValidAlbum,ValidArtist,X
  With Track
  
    ' If Prog Then PB.SetDebug ""
    Ext=ExtFromKind(.KindAsString)      ' Start by looking for correct file ext
    ' Determine path
    NewPath=""
    Best=""
    Correct=""
    Check1=True
    Skip=False
    If .TrackNumber>0 Then
      TN=.TrackNumber
      If .TrackNumber<10 Then TN="0" & TN
      If .TrackNumber<100 And .TrackCount>99 Then TN="0" & TN
    Else
      TN=""
    End If
    ValidArtist=ValidiTunes(.AlbumArtist & "","")
    If ValidArtist="" Then ValidArtist=ValidiTunes(.Artist & "","")
    If ValidArtist="" Then ValidArtist="Unknown Artist"
    AltArtist=ValidiTunes(.Artist & "","")
    If AltArtist="" Then AltArtist="Unknown Artist"
    If AltArtist=ValidArtist Then AltArtist=""
    ValidAlbum=ValidiTunes(.Album & "","")
    If ValidAlbum="" Then ValidAlbum="Unknown Album"
    Genre=ValidiTunes(.Genre & "","")
    If .Podcast=True Then
      If MoreInfo Then MsgBox "Found Podcast",0,Title
      ' NewPath=Root & "\Podcasts\" & ValidAlbum
      NewPath=FindFolder(Root & "\Podcasts",ValidAlbum)
    ElseIf .VideoKind=1 And (.Show & "")="" Then
      If MoreInfo Then MsgBox "Found Movie",0,Title
      If ValidAlbum="Unknown Album" Then ValidAlbum=ValidiTunes(.Name,"")
      NewPath=Root & "\Movies"
      Folder=FindFolder(NewPath,ValidAlbum)
      If FSO.FolderExists(Folder) Then NewPath=Folder
    ElseIf .VideoKind=3 Or (.Show & "")<>"" Then
      If MoreInfo Then MsgBox "Found TV Show",0,Title
      List=Root
      L=FindFolder(List,"TV Shows") : If L<>"" Then List=AddToList(List,L)
      L=FindFolder(List,ValidiTunes(.Show,"")) : If L<>"" Then List=AddToList(List,L)
      If ValidiTunes(.Show,"")<>TheValidName(.Show,"") Then L=FindFolder(List,TheValidName(.Show,"")) : If L<>"" Then List=AddToList(List,L)
      L=FindFolder(List,ValidiTunes(.Show & " sd","")) : If L<>"" Then List=AddToList(List,L)
      If MoreInfo Then MsgBox "Looing for TV Show in" & nl & List & nl & "Show=" & .Show,0,Title
    ElseIf (Genre<>"" AND Instr("Reference",Genre)) OR Ext=".epub" Then
      If MoreInfo Then MsgBox "Found Book",0,Title
      NewPath=FindFolder(Root & "\Books",ValidArtist)
    ElseIf (Genre<>"" AND Instr("Audiobook/Books & Spoken",Genre)) OR Ext=".m4b" Then
      If MoreInfo Then MsgBox "Found Audiobook",0,Title
      List=Root
      L=FindFolder(Root,ValidAlbum) : If L<>"" Then List=AddToList(List,L)
      L=FindFolder(Root,ValidArtist)
      If L<>"" Then
        List=AddToList(List,L)
        L=FindFolder(L,ValidAlbum) : If L<>"" Then List=AddToList(List,L)
      End If
      L=FindFolder(Root,"Audiobooks")
      If L<>"" Then
        List=AddToList(List,L)
        X=L
        L=FindFolder(X,ValidAlbum) : If L<>"" Then List=AddToList(List,L)
        L=FindFolder(X,ValidArtist)
        If L<>"" Then
          List=AddToList(List,L)
          L=FindFolder(L,ValidAlbum) : If L<>"" Then List=AddToList(List,L)
        End If
      End If
      If MoreInfo Then MsgBox List,0,Title ' Use for checking that the script is looking where we want it to
    Else
      ' Test possible alternate locations for an album until found, e.g. pre/post iTunes Media organisation or
      ' albums whose location incorrectly reflects their Compilation status. Could add alternate locations here.
      Correct=Root
      If Org Then 
        Correct=Correct & "\Music"
        ' If MoreInfo Then MsgBox "Found Music",0,Title
      End If  
      If .Compilation Then
        Correct=Correct & "\Compilations\" & ValidAlbum       
      Else
        Correct=Correct & "\" & ValidArtist & "\" & ValidAlbum
      End If
      List=Root       ' Create list of possible folders for track to be in, starting with root media folder
      ' \AlbumArtist or \AlbumArtist\Album or \AlbumArtist\Unknown Album 
      L=FindFolder(Root,ValidArtist)
      If L<>"" Then
        X=L
        List=AddToList(List,L)
        L=FindFolder(X,ValidAlbum) : If L<>"" Then List=AddToList(List,L)
        L=FindFolder(X,"Unknown Album") : If L<>"" Then List=AddToList(List,L)
        If CAL<>"" Then L=FindFolder(X,CAL) : If L<>"" Then List=AddToList(List,L)
        ' Find albums in folders of form <Album Artist> - Album>
        L=FindFolder(X,ValidArtist) : If L<>"" Then List=AddToList(List,L)
        If AltArtist<>"" Then L=FindFolder(X,AltArtist) : If L<>"" Then List=AddToList(List,L)
      End If
      ' \Artist or \Artist\Album or \Artist\Unknown Album
      If AltArtist<>"" Then 
        L=FindFolder(Root & "\Music",AltArtist)
        If L<>"" Then
          X=L
          List=AddToList(List,L)
          L=FindFolder(X,ValidAlbum) : If L<>"" Then List=AddToList(List,L)
          L=FindFolder(X,"Unknown Album") : If L<>"" Then List=AddToList(List,L)
          If CAL<>"" Then L=FindFolder(X,CAL) : If L<>"" Then List=AddToList(List,L)       
          ' Find albums in folders of form <Album Artist> - Album>
          L=FindFolder(X,ValidArtist) : If L<>"" Then List=AddToList(List,L)
          If AltArtist<>"" Then L=FindFolder(X,AltArtist) : If L<>"" Then List=AddToList(List,L)
        End If
      End If
      ' \Album (skip if Album=Artist or AlbumArtist)
      L=FindFolder(Root,ValidAlbum) : If L<>"" And Instr(List,L)=0 Then List=AddToList(List,L)
      ' \Compilations
      L=FindFolder(Root,"Compilations") : If L<>"" Then List=AddToList(List,L)
      L=FindFolder(Root & "\Compilations",ValidAlbum) : If L<>"" Then List=AddToList(List,L)
      L=FindFolder(Root & "\Compilations","Unknown Album") : If L<>"" Then List=AddToList(List,L)
      If CAL<>"" Then L=FindFolder(Root & "\Compilations",CAL) : If L<>"" Then List=AddToList(List,L)
      ' \Genre
      If Genre<>"" And FSO.FolderExists(Root & "\" & Genre) Then      
        List=AddToList(List,Root & "\" & Genre)
        ' \Genre\AlbumArtist or \Genre\AlbumArtist\Album or \AlbumArtist\Unknown Album
        L=FindFolder(Root & "\" & Genre,ValidArtist)
        If L<>"" Then
          X=L
          List=AddToList(List,L)
          L=FindFolder(X,ValidAlbum) : If L<>"" Then List=AddToList(List,L)
          L=FindFolder(X,"Unknown Album") : If L<>"" Then List=AddToList(List,L)
          If CAL<>"" Then L=FindFolder(X,CAL) : If L<>"" Then List=AddToList(List,L)
          ' Find albums in folders of form <Album Artist> - Album>
          L=FindFolder(X,ValidArtist) : If L<>"" Then List=AddToList(List,L)
          If AltArtist<>"" Then L=FindFolder(X,AltArtist) : If L<>"" Then List=AddToList(List,L)
        End If
        ' \Genre\Artist or \Genre\Artist\Album or \Artist\Unknown Album
        If AltArtist<>"" Then 
          L=FindFolder(Root & "\" & Genre,AltArtist)
          If L<>"" Then
            X=L
            List=AddToList(List,L)
            L=FindFolder(X,ValidAlbum) : If L<>"" Then List=AddToList(List,L) 
            L=FindFolder(X,"Unknown Album") : If L<>"" Then List=AddToList(List,L)
            If CAL<>"" Then L=FindFolder(X,CAL) : If L<>"" Then List=AddToList(List,L)
            ' Find albums in folders of form <Album Artist> - Album>
            L=FindFolder(X,ValidArtist) : If L<>"" Then List=AddToList(List,L)
            If AltArtist<>"" Then L=FindFolder(X,AltArtist) : If L<>"" Then List=AddToList(List,L)
          End If
        End If
      End If
      ' \Albums & Tracks for personal layout
      If FSO.FolderExists(Root & "\Albums & Tracks") Then
        If Instr("0123456789",Left(ValidArtist,1)) Then SF="123" Else SF=Left(TheValidName(ValidArtist,""),1)
        L=FindFolder(Root & "\Albums & Tracks\" & SF,TheValidName(ValidArtist,""))
        If L<>"" Then X=L : L=FindFolder(X,TheValidName(ValidAlbum,"")) : If L<>"" Then List=AddToList(List,L)
      End If
      ' \Comedy for personal layout
      If FSO.FolderExists(Root & "\Comedy") Then
        L=FindFolder(Root & "\Comedy",TheValidName(ValidArtist,""))
        If L<>"" Then X=L : L=FindFolder(X,TheValidName(ValidAlbum,"")) : If L<>"" Then List=AddToList(List,L)
      End If
      ' \Classical for personal layout
      If FSO.FolderExists(Root & "\Comedy") Then
        L=FindFolder(Root & "\Comedy",TheValidName(ValidArtist,""))
        If L<>"" Then X=L : L=FindFolder(X,TheValidName(ValidAlbum,"")) : If L<>"" Then List=AddToList(List,L)
      End If
      ' \Soundtracks for personal layout
      If FSO.FolderExists(Root & "\Soundtracks") Then
        L=FindFolder(Root & "\Soundtracks",TheValidName(ValidArtist,""))
        If L<>"" Then X=L : L=FindFolder(X,TheValidName(ValidAlbum,"")) : If L<>"" Then List=AddToList(List,L)
      End If
      ' \Music and subfolders therein
      If FSO.FolderExists(Root & "\Music") Then      
        List=AddToList(List,Root & "\Music")
        ' \Music\AlbumArtist or \Music\AlbumArtist\Album or \AlbumArtist\Unknown Album
        L=FindFolder(Root & "\Music",ValidArtist)
        If L<>"" Then
          X=L
          List=AddToList(List,L)
          L=FindFolder(X,ValidAlbum) : If L<>"" Then List=AddToList(List,L)
          L=FindFolder(X,"Unknown Album") : If L<>"" Then List=AddToList(List,L)
          If CAL<>"" Then L=FindFolder(X,CAL) : If L<>"" Then List=AddToList(List,L)
          ' Find albums in folders of form <Album Artist> - Album>
          L=FindFolder(X,ValidArtist) : If L<>"" Then List=AddToList(List,L)
          If AltArtist<>"" Then L=FindFolder(X,AltArtist) : If L<>"" Then List=AddToList(List,L)
        End If
        ' \Music\Artist or \Music\Artist\Album or \Artist\Unknown Album
        If AltArtist<>"" Then 
          L=FindFolder(Root & "\Music",AltArtist)
          If L<>"" Then
            X=L
            List=AddToList(List,L)
            L=FindFolder(X,ValidAlbum) : If L<>"" Then List=AddToList(List,L)
            L=FindFolder(X,"Unknown Album") : If L<>"" Then List=AddToList(List,L)
            If CAL<>"" Then L=FindFolder(X,CAL) : If L<>"" Then List=AddToList(List,L)
            ' Find albums in folders of form <Album Artist> - Album>
            L=FindFolder(X,ValidArtist) : If L<>"" Then List=AddToList(List,L)
            If AltArtist<>"" Then L=FindFolder(X,AltArtist) : If L<>"" Then List=AddToList(List,L)
          End If
        End If
        ' \Music\Album (skip if Album=Artist or AlbumArtist)
        L=FindFolder(Root & "\Music",ValidAlbum) : If L<>"" And Instr(List,L)=0 Then List=AddToList(List,L)
        ' \Music\Compilations
        L=FindFolder(Root & "\Music","Compilations") : If L<>"" Then List=AddToList(List,L)
        L=FindFolder(Root & "\Music\Compilations",ValidAlbum) : If L<>"" Then List=AddToList(List,L)
        L=FindFolder(Root & "\Music\Compilations","Unknown Album") : If L<>"" Then List=AddToList(List,L)
        If CAL<>"" Then L=FindFolder(Root & "\Music\Compilations",CAL) : If L<>"" Then List=AddToList(List,L)
        ' Music\Unknown Artist\Unknown Album (skip if already identified as Unknown Artist\Unknown Album)
        L=FindFolder(Root & "\Music\Unknown Artist","Unknown Album") : If L<>"" Then List=AddToList(List,L)
        If CAL<>"" Then L=FindFolder(Root & "\Music\Unknown Artist",CAL) : If L<>"" Then List=AddToList(List,L)
        ' \Various Artists (skip if AlbumArtist="Various Artists")
        L=FindFolder(Root & "\Music","Various Artists") : If L<>"" Then List=AddToList(List,L)
        L=FindFolder(Root & "\Music\Various Artists",ValidAlbum) : If L<>"" Then List=AddToList(List,L)
        L=FindFolder(Root & "\Music\Various Artists","Unknown Album") : If L<>"" Then List=AddToList(List,L)
        If CAL<>"" Then L=FindFolder(Root & "Music\Various Artists",CAL) : If L<>"" Then List=AddToList(List,L)
      End If
      ' \Unknown Artist\Unknown Album (skip if already identified as Unknown Artist\Unknown Album)
      L=FindFolder(Root & "\Unknown Artist","Unknown Album") : If L<>"" Then List=AddToList(List,L)
      If CAL<>"" Then L=FindFolder(Root & "Unknown Artist",CAL) : If L<>"" Then List=AddToList(List,L)
      ' \Various Artists (skip if AlbumArtist="Various Artists")
      L=FindFolder(Root,"Various Artists") : If L<>"" Then List=AddToList(List,L)
      L=FindFolder(Root & "\Various Artists",ValidAlbum) : If L<>"" Then List=AddToList(List,L)
      L=FindFolder(Root & "\Various Artists","Unknown Album") : If L<>"" Then List=AddToList(List,L)
      If CAL<>"" Then L=FindFolder(Root & "Various Artists",CAL) : If L<>"" Then List=AddToList(List,L)
    End If

    If .Location<>"" Then       ' Mystery bug where iTunes knows the folder but not the filename
      If FSO.GetExtensionName(.Location)="" Then
        NewPath=.Location
      Else
        NewPath=FSO.GetParentFolderName(.Location)    ' Simulate corrupt location property
      End If
      Correct=NewPath
      List=NewPath
    Else
      If NewPath="" Then NewPath=Root
      If Correct="" Then Correct=NewPath
      If List="" Then List=NewPath
    End If    
    
    Files=""
    ' Determine iTunes-like filename with leading track/disc numbers
    Name=.Name
    If .TrackNumber>0 Then
      Name=.TrackNumber & " " & Name
      If .TrackNumber<10 Then Name="0" & Name
      If .DiscNumber>1 Or (.DiscNumber=1 And .DiscCount>1) Then Name=.DiscNumber & "-" & Name
    End If
    Name=ValidiTunes(Name,"")
    
    If MoreInfo Then Trace NULL,"Potential folders for missing track: " & nl & nl & "Name" & tab & Name & nl & "Album" & tab & .Album & nl & "Artist" & tab & .Artist & nl & nl & List & nl & nl & "Correct=" & Correct
    
    List=Split(List,nl)
    
    Pass=1 : If MoreInfo Then Trace Track,"Pass 1" & nl & nl & "Looking for a file with the expected name, size, and ext " & Ext & "."
    For Each L In List       
      If Prog And Debug And Not Quit Then PB.SetDebug "<br>Looking in " & L ': WScript.Sleep 100
      F=FindFile(L,Name,Ext,.Size,Pass)       ' Try to find file of exact size!
      If Quit Then Exit Sub
      If Files<>"" And F<>"" Then Files=Files & nl & F Else Files=Files & F
      ' If Files<>"" And MoreInfo Then MsgBox "Possible match found:" & nl & nl & Files,0,Title
    Next
    
    'Second pass, if not yet found, to look for files of the form <Artist> - <Name>
    If Files="" And AltArtist<>ValidArtist Then
      Pass=2 ':  If MoreInfo Then Trace Track,"Pass 2" & nl & nl & "Looking for a file of the form <Arist> - <Name>, with the expected size, and ext " & Ext & "."
      For Each L In List       
        If Prog And Debug And Not Quit Then PB.SetDebug "<br>Looking in " & L ': WScript.Sleep 100
        ' F=FindFile(L,ValidiTunes(.Artist & " - " & .Name,""),Ext,.Size,Pass)
        F=FindFile(L,ValidName(.Artist & " - " & .Name,""),Ext,.Size,Pass)             ' Use ValidName as custom names less likely to have 40 char limit
        If Quit Then Exit Sub
        If Files<>"" And F<>"" Then Files=Files & nl & F Else Files=Files & F
      Next      
    End If


    'Custom pass, if not yet found, to look for files using Show name
    If Files="" And Not ArtistTitle And .Show<>"" Then
      Pass=2.1 ': If MoreInfo Then Trace Track,"Pass 2.1" & nl & nl & "Looking for a file in <Show>-<EpisodeNo> format, with the expected size, and ext " & Ext & "."
      For Each L In List       
        If Prog And Debug And Not Quit Then PB.SetDebug "<br>Looking in " & L ': WScript.Sleep 100
        F=FindFile(L,ValidiTunes(.Show & "-" & .EpisodeNumber,""),Ext,.Size,Pass)
        If Quit Then Exit Sub
        ' If Files<>"" And F<>"" Then Files=Files & nl & F Else Files=Files & F
      Next      
    End If

    
    ' Third pass without matching on size, and allowing for alternate extensions if supplied
    If Files="" And Not SkipOutsize Then
      If FindExt<>"" Then Ext=MergeExts(FindExt,Ext)
      Pass=3 : If MoreInfo Then Trace Track,"Pass 3" & nl & nl & "Looking for fuzzy matched files with different sizes, and ext " & Ext & "." & nl & nl & "SkipOutsize:" & SkipOutsize
      If Not ArtistTitle Then
        For Each L In List       
          If Prog And Debug And Not Quit Then PB.SetDebug "<br>Looking in " & L ': WScript.Sleep 100
          F=FindFile(L,Name,Ext,.Size,Pass)        ' Now try to find file with a fuzzy match to name!
          If Quit Then Exit Sub
          If Files<>"" And F<>"" Then Files=Files & nl & F Else Files=Files & F
        Next
      End If
      If Files="" Then
        Pass=3.1 : If MoreInfo Then Trace Track,"Pass 3.1" & nl & nl & "Looking for files which fuzzy match the form <Artist> - <Name>" & nl & nl & "PS Ext=" & Ext
        For Each L In List       
          If Prog And Debug And Not Quit Then PB.SetDebug "<br>Looking in " & L ': WScript.Sleep 100
          F=FindFile(L,ValidName(.Artist & " - " & .Name,""),Ext,.Size,Pass)           ' Now try to find file with a fuzzy match to name!
          If Quit Then Exit Sub
          If Files<>"" And F<>"" Then Files=Files & nl & F Else Files=Files & F
        Next   
      End If
      If Files<>"" Then                 ' Potential matches found  
        ' If MoreInfo Then Trace Track, "Outsize files = " & nl & F & nl & nl & "May not be connected if size is too disimilar"
        F=Split(Files,nl)
        ' Check each result and make sure not too large
        Files="" : Best=0               ' Reset the list of matches
        For Each L In F
          Diff=ABS(.Size-FSO.GetFile(L).Size)
          If Limit=0 Or Diff<Limit Then   ' If limit is set check the difference isn't too great
            If Files="" Then
              Files=L : Best=Diff
            ElseIf Diff<Best Then         ' Smallest difference first
              Files=L & nl & Files
            Else
              Files=Files & nl & L
            End If
          End If
        Next
      End If
    End If
 

    ' If Files<>"" And MoreInfo Then MsgBox "Possible match found after all passes:" & nl & nl & Files,0,Title
  
    
    ' One or more possible matches found, now choose between them
    F=Split(Files,nl)
    C=UBound(F)+1
    R=0

    If C>1 And MatchFirst Then C=1      ' Ignore multiple matches
    If C>1 Then                         ' Multiple matches found
      If SkipMulti Then 
        Skip=True
      Else
        ' MsgBox "Potential paths for missing track: " & Name & nl & nl & Files,0,Title
        R=InputBox("Multiple potential matches found for:" & Name & " [" & FormatNumber(.Size,0,-2,-2,-2) & " bytes]" & nl & nl & Index(Files) & nl & nl _
          & "Enter a value from 1-" & C & "," & nl & "X to abort script," & nl & "A to accept 1st option for all," & nl _ 
          & "0 to skip this and future multiple matches," & nl & "or press Cancel to skip this particular track.",Title)
        If R="0" Then 
          SkipMulti=True : Skip=True
        ElseIf UCase(R)="X" Then
          Quit=True : Exit Sub
        ElseIf UCase(R)="A" Then
          MatchFirst=True
          NewPath=F(0)
        Else
          R=Val(R)
          If R>0 And R<=C Then
            NewPath=F(R-1)
          Else
            Skip=True
          End If
        End If
        Check1=False
      End If
      If Skip Then NewPath="" : S=S+1
    Else
      If C=1 Then NewPath=F(0)      ' Only one match found
    End if
    
    
    ' If Files<>"" And MoreInfo Then MsgBox "Possible match found after all passes:" & nl & nl & Files,0,Title
    
        
    If FSO.FileExists(NewPath) And Not Skip Then
      R=True
      If (Check1 And Check2) Or (Abs(.Size-FSO.GetFile(NewPath).Size)>Limit And SkipOutsize=False) Then
        T="Connect:" & tab & Wrap(.Artist & " - " & .Album & " - " & TN & " " & .Name & " [" & FormatNumber(.Size,0,-2,-2,-2) & " bytes]" & nl,47," ",1)
        T=T & nl & "to:" & tab & Wrap(NewPath & " [" & FormatNumber(FSO.GetFile(NewPath).Size,0,-2,-2,-2) & " bytes]?",47,"\",1)
        T=T & nl & nl & "Difference = " & FormatNumber(ABS(.Size-FSO.GetFile(NewPath).Size),0,-2,-2,-2) & " bytes." & nl & nl
        T=T & "Yes" & tab & ": Connect to this file" & nl
        T=T & "No" & tab & ": Ignore this file" & nl
        If Abs(.Size-FSO.GetFile(NewPath).Size)>Limit And Not SkipOutsize Then
          T=T & "Cancel" & tab & ": Ignore all outsize matches"
        Else
          T=T & "Cancel" & tab & ": Abort script"
        End If
        R=MsgBox(T,vbYesNoCancel+vbQuestion,Title & " - Confimation (Pass=" & Pass & ")")
        If R=vbYes Then
          R=True
        Else
          If R=vbCancel Then
            If Abs(.Size-FSO.GetFile(NewPath).Size)>Limit And Not SkipOutsize Then
              SkipOutsize=True
            Else
              Quit=True
            End If
          End If
          R=False
        End If
      Else
        If (Abs(.Size-FSO.GetFile(NewPath).Size))<=Limit And FixOutsize=True Then
          R=True : If MoreInfo Then Trace Track,"Linking to file at path:" & nl & nl & NewPath
        Else
          If Not SkipOutsize Then Trace Track,"Have not found suitable file to match with " & Name & " [" & FormatNumber(.Size,0,-2,-2,-2) & " bytes]" & nl & nl & "Check1=" & Check1 & nl & "Check2=" & Check2 & nl & "SkipOutsize=" & SkipOutsize
        End If
      End If
      If R=True Then
        LogTrack Track,"<Location>" & NewPath
        On Error Resume Next    ' Trap possible error
        If Not TestMode Then Track.Location=NewPath
        If Err.Number<>0 Then
          Trace T,"Error setting location."
          S=S+1
        Else
          U=U+1
        End If
        On Error Goto 0         ' Restore error handler
        If TestMode Then Exit Sub       ' Skips the fix check from below !!!!!  Test code to disable !!!!!
      Else
        Skip=True
      End If
    End If
  
    ' Check that track is now reconnected, if not offer to locate manually if confirming each action
    If .Location="" And Check1 And Not Skip Then
      If Check2 And Not SkipLost Then
        ' Try to manually find file
        NewPath=BrowseForFile(Correct,Name,Ext,.Size)
        If FSO.FileExists(NewPath) Then
          LogTrack Track,"<Location>" & NewPath
          .Location=NewPath
          U=U+1
        Else
          S=S+1
        End If
      Else
        M=M+1
      End If
    End If

  End With
End Sub


' Adds values from list L2 into list L1 without duplicates
' Modified 2015-11-07
Function AddToList(L1,L2)
  Dim L,List
  If L1="" Then
    AddToList=L2
  Else
    AddToList=L1
    List=Split(L2,nl)
    For Each L In List
      If Instr(L1,L)=0 Then AddToList=AddToList & nl & L
    Next
  End If
End Function


' Browse for a file. UserAccounts.CommonDialog works on XP only!
' Error trapped for other systems to use vbScript InputBox
' Modified 2016-01-19
Function BrowseForFile(Path,Name,Ext,Size)
  Dim CD,File,R,T,W
  BrowseForFile=""
  W=""
  T="Cannot locate:" & tab & Name
  If Len(Ext)>5 Then
    T=T & nl & "of file types:" & tab 
  Else
    Name=Name & Ext
  End If
	T=T & Ext & nl & "of size:" & tab & tab & Size & nl
	T=T & "expected in:" & tab & Path & nl & nl
  T=T & "Would you like to try to find the correct file now?" & nl & nl
  T=T & "Yes" & tab & ": Browse for file" & nl
  T=T & "No" & tab & ": Ignore this file" & nl
  T=T & "Cancel" & tab & ": Don't ask to locate again"
  R=MsgBox(T,vbYesNoCancel+vbQuestion,title)
  If R=vbCancel Then SkipLost=True
  If R<>vbYes Then Exit Function
  'On Error Resume Next
  'Dim CD                 ' Handle to CommonDialog object
  'Set CD=CreateObject("UserAccounts.CommonDialog")	' XP Only!
  'Set CD=CreateObject("MSComDlg.CommonDialog")		  ' Vista/Windows 7 with MS Office Or Visual Studio? 
  'On Error Goto 0
  
  'If Err.Number<>0 Then
  '  Err.Clear
    T=W & "Please edit/correct the full path for the file that was expected to be found here:" & nl & nl & Path & "\" & Name
    If Len(Ext)>5 Then T=T & nl & "with possible file types: " & Ext : Name=Name & "."
    Do
      BrowseForFile=InputBox(W & T,Title,Path & "\" & Name)
      IF W="" Then W="File not found!" & nl & nl
    Loop Until FSO.FileExists(BrowseForFile) Or BrowseForFile=""
  'Else  
  '  Do While FSO.FolderExists(Path)=False And Instr(Path,"\")
  '    Path=Left(Path,InStrRev(Path,"\")-1)
  '  Loop
  '  CD.Filter="All Files|*.*"
  '  CD.FilterIndex=1
  '  'CD.InitialDir=Path					' XP Only
  '  CD.InitDir=Path					    ' Vista/Windows 7 with MS Office Or Visual Studio? 
  '  File=CD.ShowOpen
  '  If File=False Then
  '    BrowseForFile=""
  '  Else
  '    BrowseForFile=CD.FileName
  '  End If 
  'End If
  'On Error Goto 0
End Function


' Finalise log and open in text viewer
' Modified 2016-01-23
Sub CloseLog
  If LogOpen Then
    Dim Shell
    Set Shell=WScript.CreateObject("WScript.Shell")
    LogFile.Close
    Shell.Run """" & LogPath  & """"
  End If
End Sub


' Create a text file for output
' Modified 2016-01-23
Sub CreateLog
  Dim File,Folder,FSO,N,S,Shell,T
  Set FSO=CreateObject("Scripting.FileSystemObject")
  Set Shell=WScript.CreateObject("WScript.Shell")
  File=FSO.GetFile(WScript.ScriptFullName)
  Folder=FSO.GetParentFolderName(File)
  N=Now
  T=Replace(Title," ","")
  LogPath=Folder & "\" & T & " Log " & ValidName(FileDateTime(N),".txt")
  Set LogFile=FSO.CreateTextFile(LogPath,True,True)		' Overwrite existing, use Unicode
  T=T & " Activity Log " & FileDateTime(N)
  LogFile.WriteLine "<#>" & T
  LogFile.WriteLine "<#>" & String(Len(T),"=")
  LogFile.WriteLine ""
  LogFile.WriteLine "<#>Using ExportImport.vbs data format"
  LogFile.WriteLine ""
  LogOpen=True
End Sub


' Run script with elevated permissions if required
' Modified 2016-01-19
Sub Elevate
  Dim Shell
  If WScript.Arguments.length=0 Then
    ' MsgBox "Elevating script"
    Set Shell=CreateObject("Shell.Application")
    Shell.ShellExecute "wscript.exe", """" & WScript.ScriptFullName & """" & " uac", "", "runas", 1
    WScript.Quit        ' Otherwise we'll run the script twice
  Else
    ' MsgBox "Running elevated"
  End If
End Sub


' Determine file extension - .mp3 .mp4 .m4a .m4b .m4p .m4v .mov .mpg .mpeg .wav .aif .mid .ipa .ipg .ite .itlp .m4r .epub .pdf
' Modified 2025-04-15
Function ExtFromKind(K)
  Dim E,Q,R
  Select Case K
  Case "AAC audio file","Apple Lossless audio file","Purchased AAC audio file","Matched AAC audio file","AAC Audio"
     'E=".m4a.m4b"
		 E=".m4a"
  Case "AIFF audio file"
     E=".aif"
  Case "Apple Music AAC audio file"
     E=".m4p"
  Case "Audible file"
     E=".aa"
  Case "Book","Protected book","Purchased book"
     E=".epub"
  Case "iPad app","iPhone/iPod touch app","iPhone/iPod touch/iPad app"
     E=".ipa"
  Case "iPod game"
     E=".ipg"
  Case "iTunes Extras"
     E=".ite"
  Case "iTunes LP"
     E=".itlp"
  Case "MPEG audio file","MPEG Audio"
     E=".mp3"
  Case "MPEG-4 video file","Protected MPEG-4 video file","Purchased MPEG-4 video file"
     E=".m4v.mp4"
  Case "PDF document"
     E=".pdf"
  Case "Protected AAC audio file"
     E=".m4b.m4p"
  Case "QuickTime movie file"
     E=".mid.mov.mpg.mpeg"
  Case "Ringtone"
     E=".m4r"
  Case "WAV audio file","WAV Audio"
     E=".wav"
  Case "WMA audio file"
     E=".wma"
  Case Else
     E=""
     Trace Null,"The function ""ExtFromKind"" needs updating to generate the correct extension for files of type:" & nl & K
	End Select
  ExtFromKind=E
End Function


' Create a date & time string
' Modified 2016-01-23
Function FileDateTime(N)
  FileDateTime="[" & Year(N) & "/" & Right("0" & Month(N),2) & "/" & Right("0" & Day(N),2) & "] [" & Right("0" & Hour(N),2) & ":" & Right("0" & Minute(N),2) & "]" 
End Function


' Find a file in Path that is a Soundex match to Target.Ext
' Ext may contain multiple possible file extensions
' Modified 2025-05-29
Function FindFile(Path,Target,Exts,Size,Pass)
  ' MsgBox "Looking for " & Target & " in" & nl & Path,0,Title
  FindFile=""
  If FSO.FolderExists(Path) Then
    Dim D,Diff,E,F,L,N,M,Q,R,S,T,U,X,Ext,Snap
    If Len(Exts)<6 And Instr(Path,"\Unknown Artist\Unknown Album") And Size>0 Then      ' Skip fuzzy matching
      T=Path & "\" & ValidiTunes(Target,Exts)
      If FSO.FileExists(T) Then FindFile=T                                              ' Exact match found
    Else
      Ext=Exts                              ' Avoid altering value passed by ref.
      
      D=Instr(Target," - ")
      If D>6 Then                           ' Avoid possible issue with Amazon style naming E.g. <Artist> - <Name>
        T=Soundex(Left(Target,D-1))+"-"+Soundex(Mid(Target,D+3))
      Else
        T=Soundex(Target)
      End If
      
      U=UCase(Target)
      L=Len(T)
      ' MsgBox "Target" & tab & Target & nl & "Soundex" & tab & T,0,Title
      Set F=FSO.GetFolder(Path)
      Do While Instr(Ext,".")>0 And FindFile=""
        E=Mid(Ext,InstrRev(Ext,"."))        ' Get an extension from a list, last first
        Ext=Left(Ext,Len(Ext)-Len(E))
        X=Len(E)
        For Each S In F.Files
          
          ' If MoreInfo Then Trace Null,"Checking file:" & nl & S.Path & " [" & T & "]" & nl & "Size=" & Size & nl & nl & "Pass " & Pass
          
          Diff=ABS(Size-S.Size)
          If Limit=0 Or Diff<Limit Then     ' Ignore files of the "wrong" size  
            N=S.Name
            If LCase(Right(N,X))=E Then     ' Exts match
              M=UCase(Left(N,Len(N)-X))
                   
              D=Instr(M," - ")
              If D>6 Then                   ' Avoid possible issue with Amazon naming
                N=Soundex(Left(N,D-1))+"-"+Soundex(Mid(M,D+3))
              Else
                N=Soundex(M)
              End If
              
              ' MsgBox "[" & T & "]" & nl & "[" & N & "]" & nl & (Left(N,L)=Left(T,Len(N)))
              If Left(N,L)=Left(T,Len(N)) Then                  ' Makes sure short partial matches work
                If MoreInfo Then Trace Null,"Pass=" & Pass & nl & nl & "Comparing: " & nl & "[" & T & "] " & Target & Exts &  "   with " & nl & "[" & N & "] " & S.Name & nl & nl & "Size: " & FormatNumber(Size,0,-2,-2,-2) & " ~ " & FormatNumber(S.Size,0,-2,-2,-2) & ", diff=" & FormatNumber(Diff,0,-2,-2,-2)
                If M=U Then FindFile=S.Path : Exit Function     ' Exact match found, don't bother looking for fuzzies
                If FindFile="" Then FindFile=S.Path Else FindFile=FindFile & nl & S.Path
              End If
            End If
          End If
        Next
      Loop
    End If
  End If
End Function


' Find all subfolders of Path that are a Soundex match to Target. Expanded for Path as a list.
' Modified 2015-12-18
Function FindFolder(Path,Target)
  Dim F,L,N,R,S,T,W,X,List
  ' If Path="<Some Test Path>" Then 
  ' MsgBox "Looking for " & Target & " in" & nl & Path,0,Title
  R=""
  If Target<>"" Then
    'If Left(Target,2)="A " Then R=FindFolder(Path,Mid(Target,3))
    'If Left(Target,3)="An " Then R=FindFolder(Path,Mid(Target,4))
    'If Left(Target,4)="The " Then R=FindFolder(Path,Mid(Target,5))
    If Left(Target,2)<>"# " Then R=FindFolder(Path,"# " & FirstLast(Target))    ' Avoid endless recursion
    T=Soundex(Target)
    W=Len(T)
    List=Split(Path,nl)
    For Each L In List
      If FSO.FolderExists(L) Then
        Set F=FSO.GetFolder(L)
        On Error Resume Next                    ' Trap potential error
        For Each S in F.SubFolders
          N=Soundex(S.Name)
          ' If MoreInfo Then Trace NULL, "Target:" & nl & Target & "=" & T & nl & "Subfolder:" & nl & S.Name & "=" & N
          If Left(N,W)=Left(T,Len(N)) Then      ' Makes sure short partial matches work
            'If R="" Then R=S.Path Else R=R & nl & S.Path
            R=AddToList(R,S.Path)
          End If
        Next
        ' Err.Raise 1,"FindFolder","Test"       ' Test Trace feature
        If Err.Number<>0 Then                   ' Report error if one occurred, and attempt to continue
          Trace Null,"Problem processing subfolders of:" & nl & nl & L & nl & nl & "Error" & tab & Err.Number & nl & "Desc." & tab & Err.Description & nl & "Module" & tab & "FindFolder"
          Best="NULL"
        End If
        On Error Goto 0         ' Restore normal error handler
      End If
    Next
    ' Look for subfolders for CDs  
    If R<>"" Then
      X=R
      X=FindFolder(X,"CD")
      IF X<>"" Then R=AddToList(R,X)
    End If
  End If  
  FindFolder=R
End Function


' Move first word to end of string after a comma
' Modified 2015-04-12
Function FirstLast(S)
  Dim P,V
  V=Trim(S)             ' Prevent errors
  P=Instr(V," ")
  If P>0 Then 
    FirstLast=Mid(V,P+1) & ", " & Left(V,P-1)
  Else
    FirstLast=""
  End If
End Function


' Determine media folder layout
' Modified 2016-01-19
Function GetLayout
  Dim File,Line,P,Prefs
  GetLayout=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
      GetLayout=Eval(Mid(Line,P+9,1))
      Exit Do
    End If
  Loop
  File.Close
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 iTunes Media folder
' Modified 2021-07-31
Sub GetRoot
  Check2=Check          ' Place confirmation routine in Action not ProcessTracks
  ' MsgBox "Check2=" & Check2,0,"Delete/Hide this test message"
  Check=False
  If Check2 Then Prog=False
  Set FSO=CreateObject("Scripting.FileSystemObject")
  'Set SH=CreateObject("Shell.Application") 
  If Root<>"" Then If FSO.FolderExists(Root)=False Then Root=""
  If Root="" Then
    Root=GetMediaPath
    If Root="" Then
      On Error Resume Next      ' Ignore potential error with this call
      Root=iTunes.LibraryXMLPath
      Root=Left(Root,InStrRev(Root,"\")-1)
      On Error Goto 0           ' Restore normal error handler
    End If
    Do
      If FSO.FolderExists(Root & "\iTunes Media") Then Root=Root & "\iTunes Media"
      If FSO.FolderExists(Root & "\iTunes Music") Then Root=Root & "\iTunes Music"
      Root=InputBox("Please confirm/edit the location of your iTunes Media folder or the location you would like to check for missing files.",Title,Root)
      If Right(Root,1)="\" Then Root=Left(Root,Len(Root)-1)
      If Root="" Then WScript.Quit
    Loop Until FSO.FolderExists(Root)
  End If  
  If FSO.FolderExists(Root & "\Music") Then
    Org=True
  Else
    Org=False
  End If
End Sub


' Add index numbers to a list of file paths, add file sizes and separated by newlines
' Modified 2014-06-17
Function Index(L)
  Dim A,C,I,S
  C=0 : S=""
  A=Split(L,nl)
  For Each I in A
    C=C+1
    If C>1 Then S=S & nl & nl
    S=S & C & ": " & I & " [" & FormatNumber(FSO.GetFile(I).Size,0,-2,-2,-2) & " bytes]"
  Next
  Index=S
End Function


' Custom info message for progress bar
' Modified 2015-01-26
Function Info(T)
  On Error Resume Next
  Dim A,B
  With T
    If Instr(.KindAsString,"audio stream") Then
      A=.KindAsString
      B=" "
    ElseIf T.Kind=5 Then
      A="iCloud item"
      B="Ignore"
    Else    
      A=.AlbumArtist & "" : If A="" Then A=.Artist & "" : If A="" Then A="Unknown Artist"
      B=.Album & "" : If B="" Then B="Unknown Album"
    End If
    Info="Checking: " & A & " - " & B & " - " & .Name
    If Err.Number>0 Then
      Trace T,"Problem processing item:" & nl & nl & "Name" & tab & .Name & nl & "Kind" & tab & .KindAsString & nl & "Error" & tab & Err.Number & nl & "Desc." & tab & Err.Description & nl & "Module" & tab & "Info"
    End If
  End With
End Function


' Key track information
' Modified 2016-01-23
Function KeyText(T)
  Dim AA,AL,AR,DC,DN,KT,TN
  With T
    AA=.AlbumArtist & "" : If AA="" Then AA=.Artist & "" : If AA="" Then AA="Unknown Artist"
    AL=.Album & "" : If AL="" Then AL="Unknown Album"
    DN=.DiscNumber
    DC=.DiscCount
    TN=.TrackNumber
    KT=AA & "\" & AL & "\"
    If TN>0 Then
      If DN>1 Or (DN>0 And DC>1) Then KT=KT & DN & "-"
      If TN<10 Then KT=KT & "0"
      KT=KT & TN & " "
    End If
    KeyText=KT & .Name
  End With
End Function


' Save log information
' Modified 2016-01-23
Sub LogLine(L)
  If Logging Then
    If Not LogOpen Then CreateLog
    LogFile.WriteLine L
  End If
End Sub


' Create a log record for a track
' Modified 2016-01-23
Sub LogTrack(T,S)
  If Logging Then
    LogLine ""
    LogLine "<ID>" & PersistentID(T)
    LogLine "<#>" & KeyText(T)
    LogLine S
  End If
End Sub


' Merge two strings of extensions of form ".<ext1>.<ext2>" - no validity checks, intentionally reverses order for priority, .e.g. expect ext, then others in reverse of order given
' Modified 2025-05-29
Function MergeExts(L1,L2)
  Dim E,Ext,L3
  MergeExts=""
  Ext=L1
  L3=L2
  Do While Instr(Ext,".")>0
    E=Mid(Ext,InstrRev(Ext,"."))        ' Get an extension from a list, last first
    Ext=Left(Ext,Len(Ext)-Len(E))
    If Not (Instr(L3,E)>0) Then MergeExts=MergeExts & E
  Loop
  MergeExts=MergeExts & L3
 End Function



' Custom prompt for track-by-track confirmation
' Modified 2012-09-11
Function Prompt(T)
  Dim A,B
  With T
    A=.AlbumArtist & "" : If A="" Then A=.Artist & "" : If A="" Then A="Unknown Artist"
    B=.Album & "" : If B="" Then B="Unknown Album"
    Prompt="Try to find?" & nl & nl & "Artist" & tab & ": " & A & nl & "Album" & tab & ": " & B & nl _ 
      & "Name" & tab & ": " & .Name & nl & "Track #" & tab & ": " & .TrackNumber
  End With
End Function


' Generate code value for Soundex
' Modified 2011-10-11
Function SoundCode(C)
  Select Case C
  Case "B","F","P","V"
    SoundCode="1"
  Case "C","G","J","K","Q","S","X","Z"
    SoundCode="2"
  Case "D","T"
    SoundCode="3"
  Case "L"
    SoundCode="4"
  Case "M","N"
    SoundCode="5"
  Case "R"
    SoundCode="6"
  Case Else
    SoundCode=""
  End Select
End Function
 

' Generate Soundex coding for input string
' Ignore leading non-alphas in input and optionally suppress trailing zeros from result and/or transpose "&" for "and"
' Modified 2025-05-31
Function Soundex(S)
  Dim C,I,P,R
  If S="" Then Soundex="" : Exit Function
  If SwapAmp Then S=Replace(S," & "," and ")                    ' Patch for transposition of "and" with "&" - might not always be useful 2025/05/31 so now an option
  ' If SwapAmp Then S=Replace(S," and "," & ")                  ' alternate swap order, probably not needed
  I=0
  Do
    I=I+1
    C=Asc(UCase(Mid(S,I,1)))
  Loop Until (C>64 And C<91) Or I=Len(S)
  If I=Len(S) Then Soundex=S : Exit Function    ' If no alphas return original input
  If Len(S)=I Then
    Soundex=UCase(Mid(S,I,1))
  Else
    R=UCase(Mid(S,I,1)) : P="7"
    I=I+1
    Do
      C=SoundCode(UCase(Mid(S,I,1)))
      If C<>P Then
        R=R & C
        P=C
      End If
      I=I+1
    Loop While I<Len(S) And Len(R)<4
    If Not ShortMatch Then If Len(R)<4 Then R=R & String(4-Len(R),"0") ' Comment out if short names cannot be matched
    Soundex=R
  End If
End Function


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


' Moves any leading "The " to the end of the string so folder order matches
' iTunes sorting (more or less) while still showing the full title.
' Modified 2011-06-23
Function TheValidName(N,E)
  N=ValidName(N,E)
  If Left(N,4)="The " Then N=Mid(N,5) & ", The"
  TheValidName=N & E
End Function


' Custom trace messages for troubleshooting, T is the current track if needed, Null otherwise 
' Modified 2014-05-12
Sub Trace(T,M)
  If Tracing Then
    Dim R,Q
    If IsNull(T) Then
      Q=M & nl & nl
    Else
      Q=Info(T) & nl & nl & M & nl & nl
    End If    
    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 Quit=True : Report : WScript.Quit
    If R=vbNo Then Tracing=False
  End If
End Sub


' Test for tracks which can be usefully updated
' Modified 2025-05-19
Function Updateable(T)
  Updateable=False
  If Instr(T.KindAsString,"audio stream")=0 Then
    If T.Location="" Then 
      Updateable=True                   ' This script works with missing files, ignore streams
    ElseIf FSO.GetExtensionName(T.Location)="" Then
      ' Trace T, "Track with bad location property:" & nl & nl & T.Location
      Updateable=True
    ' Else                                 ' Simulate corrupt location propery
    '   Trace T, "Track with bad location property:" & nl & nl & FSO.GetParentFolderName(T.Location)
    '   Updateable=True
    End If
  End If
End Function


' Reads value from string.
' Modified 2011-02-02
Function Val(T)
  Dim A,I
  I=1
  Val=0
  If T<>"" Then
    Do
      A=Asc(Mid(T,I))-48
      IF A<0 Or A>9 Then Exit Do
      Val=Val*10+A
      I=I+1
      If I>Len(T) Then Exit Do
    Loop
  End If
End Function

  
' Replace invalid filename characters: \ / : * ? " < > | and also ; with underscores
' Replace leading space or period, strip trailing spaces, trailing periods allowed except for folders
' File names (inclusive of extension) & folder names limited to 40 characters
' A name consisting only of spaces has the leading space changed to an underscore
' Pass name and extension, extension="" for folders
' Modified 2011-06-23
Function ValidiTunes(I,E)
  If I="" Then ValidiTunes="" : Exit Function
  Dim N : N=I                   ' Prevent pass by reference error
  N=Left(N,40-Len(E))		        ' It may help not to automatically truncate names and let FindFile/FindFolder do the work
  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,";","_")
  IF N=String(Len(N)," ") Then
    N=N="_" & Mid(N,2)
  Else
    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) & "_"
  End If
  ValidiTunes=N & E
End Function


' Replace invalid filename characters: \ / : * ? " < > | per http://support.microsoft.com/kb/177506
' Strip leading/trailing spaces & leading periods, trailing periods allowed except for folders
' Change the replacement characters on the right for other valid characters if required
' A name consisting only of spaces or periods is changed to a single underscore
' Pass name and extension, extension="" for folders
' Modified 2012-01-04
Function ValidName(I,E)
  If I="" Then ValidName="" : Exit Function
  Dim N : N=I                   ' Prevent pass by reference error
  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)=".")
    N=Mid(N,2)
    If N=" " Or N="." Then N="_" ' Prevent name from vanishing
  Loop 
  Do While Right(N,1)=" " Or (E="" And Right(N,1)=".")
    N=Left(N,Len(N)-1)
  ' If N=" " Or N="." Then N="_" ' Prevent name from vanishing - Redundant!
  Loop 
  ValidName=N & E
End Function


' ============================================
' Reusable Library Routines for iTunes Scripts
' ============================================
' Modified 2015-01-24


' Get extension from file path
' Modified 2015-01-24
Function Ext(P)
  Ext=LCase(Mid(P,InStrRev(P,".")))
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 2014-05-05
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 before use."
    If Prog And UAC Then
      Q=Q & nl & nl & "NB: Use the EnableLUA script to allow the progress bar to" & nl
      Q=Q & "function or change the declaration ''Prog=True'' to " & nl & "''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 2012-09-05
Function ObjectFromID(ID)
  Set ObjectFromID=iTunes.LibraryPlaylist.Tracks.ItemByPersistentID(Eval("&H" & Left(ID,8)),Eval("&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 2015-01-24
Function PersistentObject(T)
  Dim E,L
  Set PersistentObject=T
  On Error Resume Next  ' Trap possible error
  If Instr(T.KindAsString,"audio stream") Then
    L=T.URL 
  ElseIf T.Kind=5 Then
    L="iCloud/Shared"
  Else
    L=T.Location
  End If
  If Err.Number<>0 Then
    Trace T,"Error reading location property from object."
  ElseIf L<>"" Then
    E=Ext(L)
    If Instr(".ipa.ipg.m4r",E)=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 2017-03-06
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)
    If T Is Nothing Then
      ' Something went wrong fetching the track object, move on to the next item
    ElseIf T.Kind=1 Then        ' Ignore tracks which can't change
      Set T=PersistentObject(T) ' Attach to object in library playlist
      If Prog Then PB.SetInfo Info(T)
      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
    ' WScript.Sleep 500         ' Slow down progress bar when testing
    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 2014-04-29
Sub Report
  If Not Outro Then Exit Sub
  Dim L,T
  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 updating")
  If U>0 Or V=0 Then L=PrettyList(L,GroupDig(U) & Plural(U," were"," was") & " updated")
  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 on first separator C found at or before character W adding T tabs to each new line
' Modified 2014-05-29
Function Wrap(S,W,C,T)
  Dim P,Q
  P=InstrRev(S," ",W)
  Q=InstrRev(S,"\",W)
  If Q>P Then P=Q
  If P Then
    Wrap=Left(S,P) & nl & String(T,tab) & Wrap(Mid(S,P+1),W,C,T)
  Else
    Wrap=S
  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 uninteruppted 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
' ==============