' ==========
' FindTracks
' ==========
' Version 1.0.0.6 - January 4th 2012
' Copyright © Steve MacGuire 2010-2012
' 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

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

' =============================
' Declare constants & variables
' =============================
Option Explicit	        ' Declare all variables before use
Const Kimo=False        ' True if script expects "Keep iTunes Media folder organised" to be disabled
Const Min=0             ' 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 procssing above this level
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 M,P,S,U,V           ' Counters
Dim nl,tab              ' New line/tab strings
Dim Quit                ' Used to abort script

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

Dim Org                 ' Media organisation flag
Dim FSO                 ' Handle to FileSystemObject
Dim Root                ' Root of media library
Dim Check2              ' Alternate check flag

' =======================
' Initialise user options
' =======================
Intro=True              ' Set false to skip initial prompts, avoid if non-reversible actions
Outro=True              ' Produce summary report
Check=True              ' Track-by-track confirmation
Prog=True               ' Display progress bar
Debug=True              ' Include any debug messages in progress bar
Timing=True             ' Display running time
Named=False             ' Force script to process specific playlist rather than current selection
Source="Library"        ' Named playlist to process, use "Library" for entire library

Root=""                 ' Edit to predefine root media folder


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


' 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 2012-01-04
Sub Action(Track)
  If Track.Location<>"" Then Exit Sub
  Dim AltArtist,C,Check1,Correct,Ext,F,Files,Folder,L,List,Name,NewPath,R,Skip,T,ValidAlbum,ValidArtist
  With Track
    ' If Prog Then PB.SetDebug ""
    Ext=ExtFromKind(.KindAsString)
    ' Determine path
    NewPath=""
    Correct=""
    Check1=True
    Skip=False
    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"
    If .Podcast=True Then
      ' MsgBox "Found Podcast"
      NewPath=Root & "\Podcasts\" & ValidAlbum
      NewPath=FindFolder(Root & "\Podcasts",ValidAlbum)
    ElseIf .VideoKind=1 Then
      ' MsgBox "Found Movie"
      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 Then
      ' MsgBox "Found TV Show"
      NewPath=FindFolder(Root & "\TV Shows",ValidiTunes(.Show,""))
      If .SeasonNumber>0 Then Folder=NewPath & "\Season " & .SeasonNumber
      IF FSO.FolderExists(Folder) Then NewPath=Folder
    ElseIf (.Genre<>"" AND Instr("Reference",.Genre)) OR Ext=".epub" Then
      ' MsgBox "Found Book"
      NewPath=FindFolder(Root & "\Books",ValidArtist)
    ElseIf (.Genre<>"" AND Instr("Audiobook/Books & Spoken",.Genre)) OR Ext=".m4b" Then
      ' MsgBox "Found Audiobook"
      NewPath=FindFolder(Root & "\AudioBooks",ValidArtist)
      Folder=FindFolder(NewPath,ValidAlbum)
      IF FSO.FolderExists(Folder) Then NewPath=Folder
    Else
      ' MsgBox "Found Music"
      ' Test possible alternate locations for an album until found, e.g. pre/post iTunes Media organisation or
      ' albums whose location incorrectly reflects their Compliation status. Could add alternate locations here.
      If .Compilation Then
        Correct=Root & "\Compilations\" & ValidAlbum       
      Else
        Correct=Root & "\" & 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
      L=FindFolder(Root,ValidArtist) : If L<>"" Then List=List & nl & L : L=FindFolder(L,ValidAlbum) : If L<>"" Then List=List & nl & L
      ' \Artist or \Artist\Album
      If AltArtist<>"" Then L=FindFolder(Root,AltArtist) : If L<>"" Then List=List & nl & L : L=FindFolder(L,ValidAlbum) : If L<>"" Then List=List & nl & L
      ' \Album (skip if Album=Artist or AlbumArtist)
      L=FindFolder(Root,ValidAlbum) : If L<>"" And Instr(List,L)=0 Then List=List & nl & L
      ' \Compilations
      L=FindFolder(Root & "\Compilations",ValidAlbum) : If L<>"" Then List=List & nl & L
      ' \Music and subfolders therein
      If FSO.FolderExists(Root & "\Music") Then      
        List=List & nl & Root & "\Music"
        ' \Music\AlbumArtist or \Music\AlbumArtist\Album
        L=FindFolder(Root & "\Music",ValidArtist) : If L<>"" Then List=List & nl & L : L=FindFolder(L,ValidAlbum) : If L<>"" Then List=List & nl & L
        ' \Music\Artist or \Music\Artist\Album
        If AltArtist<>"" Then L=FindFolder(Root & "\Music",AltArtist) : If L<>"" Then List=List & nl & L : L=FindFolder(L,ValidAlbum) : If L<>"" Then List=List & nl & L
        ' \Music\Album (skip if Album=Artist or AlbumArtist)
        L=FindFolder(Root & "\Music",ValidAlbum) : If L<>"" And Instr(List,L)=0 Then List=List & nl & L
      ' \Compilations
        L=FindFolder(Root & "\Music\Compilations",ValidAlbum) : If L<>"" Then List=List & nl & L
      ' Unknown Artist\Unknown Album
        If FSO.FolderExists(Root & "\Music\Unknown Artist\Unknown Album") Then List=List & nl & Root & "\Music\Unknown Artist\Unknown Album"
      End If
      ' \Unknown Artist\Unknown Album
      If FSO.FolderExists(Root & "\Unknown Artist\Unknown Album") Then List=List & nl & Root & "\Unknown Artist\Unknown Album"
    End If

    If NewPath="" Then NewPath=Root
    If Correct="" Then Correct=NewPath
    If List="" Then List=NewPath
    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,"")
    'MsgBox "Potential folders for missing track: " & Name & nl & nl & List,0,Title
    List=Split(List,nl)
    For Each L In List       
      If Prog And Debug And Not Quit Then PB.SetDebug "<br>Looking in " & L ': WScript.Sleep 100
      ' Now try to find that file!
      F=FindFile(L,Name,Ext)
      If Files<>"" And F<>"" Then Files=Files & nl & F Else Files=Files & F
    Next
    'MsgBox "Potential paths for missing track: " & Name & nl & nl & Files,0,Title
    F=Split(Files,nl)
    C=UBound(F)+1
    R=0

    If C>1 Then         ' Multiple matches found
      R=InputBox("Multiple potential matches found for:" & Name & nl & nl & Index(Files) & nl & nl _
        & "Enter 1-" & C & " or press Cancel to skip.",Title)
      R=Val(R)
      If R>0 And R<=C Then
        NewPath=F(R-1)
      Else
        NewPath=""
        S=S+1
        Skip=True
      End If
      Check1=False
    Else
      If C=1 Then NewPath=F(0)      ' Only one match found
    End if
    
    If FSO.FileExists(NewPath) And Not Skip Then
      R=True
      If Check1 And Check2 Then
        T="Reconnect " & .Artist & " - " & .Album & " - " & .TrackNumber & " " & .Name & " to:" & nl & nl & NewPath & "?"
        R=MsgBox(T,vbYesNoCancel+vbQuestion,title)
        If R=vbCancel Then Quit=True : Exit Sub
        If R=vbYes Then
          R=True
        Else
          R=False
        End If
      End If
      If R=True Then
        .Location=NewPath
        U=U+1
      Else
        Skip=True
      End If
    End If

    If .Location="" And Check1 And Not Skip Then
      If Check2 Then
        ' Try to manually find file
        NewPath=BrowseForFile(Correct,Name,Ext)
        If FSO.FileExists(NewPath) Then
          .Location=NewPath
          U=U+1
        Else
          S=S+1
        End If
      Else
        M=M+1
      End If
    End If

  End With
End Sub


' Browse for a file. UserAccounts.CommonDialog works on XP only!
' Error trapped for other systems to use vbScript InputBox
' Modified 2011-10-12
Function BrowseForFile(Path,Name,Ext)
  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 & "in folder:" & tab & tab & Path & nl & nl
  T=T & "Would you like to try to find the correct file now?"
  R=MsgBox(T,vbYesNoCancel+vbQuestion,title)
  If R=vbCancel Then Quit=True : Exit Function
  IF R=vbNo 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


' Determine file extension - .mp3 .mp4 .m4a .m4b .m4p .m4v .mov .mpg .mpeg .wav .aif .mid .ipa .ipg .ite .itlp .m4r .epub .pdf
' Modified 2011-10-11
Function ExtFromKind(K)
  Dim E
  Select Case K
  Case "AAC audio file","Apple Lossless audio file","Purchased AAC audio file"
     E=".m4a.m4b"
  Case "AIFF audio file"
     E=".aif"
  Case "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"
     E=".mp3"
  Case "MPEG-4 video file","Protected 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"
     E=".wav"
  Case Else
     E=""
     MsgBox "This script needs updating to generate correct the extension for files of type:" & nl & K,0,Title
  End Select
  ExtFromKind=E
End Function


' Find a file in Path that is a soundex match to Target.Ext
' Ext may contain multiple possible file extensions
' Modified 2012-01-04
Function FindFile(Path,Target,Exts)
  FindFile=""
  If FSO.FolderExists(Path) Then
    Dim E,F,L,N,M,R,S,T,U,X,Ext
    If Len(Exts)<6 And Instr(Path,"\Unknown Artist\Unknown Album") 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.
      T=Soundex(Target)
      U=UCase(Target)
      L=Len(T)
      Set F=FSO.GetFolder(Path)
      Do While Instr(Ext,".")>0 And FindFile=""
        E=Mid(Ext,InstrRev(Ext,"."))      ' Get an extension from a list
        Ext=Left(Ext,Len(Ext)-Len(E))
        X=Len(E)
        For Each S In F.Files
          N=S.Name
          If LCase(Right(N,X))=E Then     ' Exts match
            M=UCase(Left(N,Len(N)-X))
            N=Soundex(M)
            If Left(N,L)=Left(T,Len(N)) Then
              If M=U Then FindFile=S.Path : Exit Function         ' Exact match found
              If FindFile="" Then FindFile=S.Path Else FindFile=FindFile & nl & S.Path
            End If
          End If
        Next
      Loop
    End If
  End If
End Function


' Find all subfolders of Path that are a Soundex match to Target, ensure match
' Modified 2011-10-21
Function FindFolder(Path,Target)
  FindFolder=""
  IF FSO.FolderExists(Path) Then
    Dim F,R,S,T
    T=Soundex(Target)
    R=""
    Set F=FSO.GetFolder(Path)
    For Each S in F.SubFolders
      If Soundex(S.Name)=T Then
        If R="" Then R=S.Path Else R=R & nl & S.Path
      End If
    Next
    FindFolder=R
  End If
End Function


' Attempt to determine root of media path by inspecting location of media files
' Modified 2011-12-01
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=.Location
        IF L<>"" Then
          A=.AlbumArtist
          IF A="" Then A=.Artist
          A=ValidiTunes(A,"")
          If .Compilation 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 Instr(L,A) Then
            P=Left(L,Instr(L,A)-2)
            S=Mid(P,InStrRev(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 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 2011-10-21
Sub GetRoot
  Check2=Check          ' Place confirmation routine in Action not ProcessTracks
  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
      Root=iTunes.LibraryXMLPath
      Root=Left(Root,InStrRev(Root,"\")-1)
    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 values separated by newlines
' or return value V from the list
' Modified 2011-10-21
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
    S=S & C & ". " & I
  Next
  Index=S
End Function


' Custom info message for progress bar
' Modified 2011-10-24
Function Info(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"
    Info="Checking: " & A & " - " & B & " - " & .Name
  End With
End Function


' Custom prompt for track-by-track confirmation
' Modified 2011-10-24
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 suppress trailing zeros from result
' Modified 2011-10-21
Function Soundex(S)
  Dim C,I,P,R
  If S="" Then Soundex="" : Exit Function
  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)) ' & "000"
  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 Len(R)<4 Then R=R & String(4-Len(R),"0")
    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


' Test for tracks which can be usefully updated
' Modified 2011-10-11
Function Updateable(T)
  If T.Location="" Then       ' This script works with missing files
    Updateable=True
  Else                        ' No updating values which won't change
    Updateable=False
  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 extention) & folder names limited to 40 characters
' A name consisting only of spaces has the leading space changed to an underscore
' Pass name and extention, extention="" 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 extention, extention="" 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 2011-11-13


' 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 2011-11-13
Sub GetTracks
  Dim Q,R
  ' Initialise global variables
  nl=vbCrLf : tab=Chr(9) : Quit=False
  M=0 : P=0 : S=0 : U=0 : V=0
  ' Initialise global objects
  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 " & Count & " tracks"
    If Named Then Q=Q & nl
  Else
    Q=Q & "Process " & 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: Disable User Access Control to allow progess bar to operate" & nl
      Q=Q & "or change the declaration ''Prog=True'' to ''Prog=False''."
      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


' 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


' Loop through track selection processing suitable items
' Modified 2011-11-06
Sub ProcessTracks
  Dim C,I,N,Q,R,T
  N=0
  If Prog Then                  ' Create ProgessBar
    Set PB=New ProgBar
    PB.SetTitle Title
    PB.Show
  End If
  Clock=0 : StartTimer
  For I=Count To 1 Step -1      ' 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 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)
          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
      Else
        If T.Location<>"" Then V=V+1    ' Increment unchanging tracks, exclude missing ones
      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 500
    PB.Close
  End If
End Sub


' Output report
' Modified 2011-10-24
Sub Report
  If Not Outro Then Exit Sub
  Dim T
  If Quit Then T="Script aborted!" & nl & nl Else T=""
  T=T & P & " track" & Plural(P,"s","")
  If P<Count Then T=T & " of " & count
  T=T & Plural(P," were"," was") & " processed of which " & nl
  If V>0 Then
    T=T & V & " did not need updating"
    If (U>0)+(S>0)+(M>0)<-1 Then
      T=T & "," & nl
    ElseIf (U>0)+(S>0)+(M>0)=-1 Then
      T=T & " and" & nl
    End If
  End If
  If U>0 Or V=0 Then
    T=T & U & Plural(U," were"," was") & " updated"
    If (S>0)+(M>0)<-1 Then
      T=T & "," & nl
    ElseIf (S>0)+(M>0)=-1 Then
      T=T & " and" & nl
    End If
  End If
  If S>0 Then
    T=T & S & Plural(S," were"," was") & " skipped"
    If M>0 Then T=T & " and" & nl
  End If
  If M>0 Then T=T & M & Plural(M," were"," was") & " missing"
  T=T & "."
  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


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


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

' Progress/activity bar for vbScript implemented via IE automation
' Can optionally rebuild itself if closed or abort the calling script
' Modified 2011-10-18
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 2011-10-16
  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=140                ' Height of containing div
    Else
      Height=100                ' 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 2011-10-17
  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 "<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+30           ' Increase if using more cells
      .height=Height+55         ' 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
      .menubar=False
      .resizable=False
      .toolbar=False
      On Error Resume Next      
      .statusbar=False          ' Causes error on 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
' ==============