' =============
' SortDateAdded
' =============
' Version 1.0.1.9 - July 16th 2012
' Copyright © Steve MacGuire 2010-2012
' http://samsoft.org.uk/iTunes/SortDateAdded.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 remove and reimport tracks so that Date Added (Descending) order matches natural album order.
' Assumes tracks have sensible path data so that ordering by path equates to correct track order.

' =========
' ChangeLog
' =========
' Version 1.0.0.1 - Initial version
' Version 1.0.0.2 - Remove & reimport tracks rather than try to reassign existing library entries
' Version 1.0.0.3 - Prevent two or more tracks having the same DateAdded value (in seconds)
' Version 1.0.0.4 - Preserve volatile iTunes-only metadata, including playlist membership
' Version 1.0.0.5 - If no tracks are pre-selected then process current playlist
' Version 1.0.0.6 - Ignore non-file tracks, fix behaviour with PDF's, preserve more metadata
' Version 1.0.0.7 - Extend to .wav, .aif .ite & .itlp filetypes
' Version 1.0.0.8 - Extend to .mid
' Version 1.0.0.9 - Minor tweak to array declaration and use of With Object Statement (might speed up the script slightly)
' Version 1.0.1.1 - Add flag to control order
' Version 1.0.1.2 - Time zone correction for restored LastPlayed & LastSkipped
' Version 1.0.1.3 - Updated to new common code base
' Version 1.0.1.4 - Add pauses into code between adding a file and updating it to address possible timing issue
' Version 1.0.1.5 - Better test for completion of add file process
' Version 1.0.1.6 - Another approach! Test ability to edit track info. loop and retry until able to update
' Version 1.0.1.7 - Change sorting criteria to make independant of file path
' Version 1.0.1.8 - Fix for problem setting Exclude From Shuffle flag
' Version 1.0.1.9 - Expanded error handling

' ==========
' To-do List
' ==========
' Add things to do...

' =============================
' 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, 0 for current playlist/library
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 LT                  ' Last track added time 
Dim Desc                ' Sort order
Dim TimeFactor          ' No. of hours to add/subtract to/from PlayedDate to correct for time zone
Dim Title,Summary       ' No prizes for these two

' =======================
' Initialise user options
' =======================
Intro=True              ' Set false to skip initial prompts, avoid if non-reversible actions
Outro=True              ' Produce summary report
Check=False             ' Track-by-track confirmation
Prog=True               ' Display progress bar
Debug=True              ' Include any debug messages in progress bar
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

Desc=True               ' True=Descending order, False=Ascending

Title="Sort Date Added"
Summary="Remove and reimport tracks so they are listed correctly when" & vbCrLf _ 
  & "the library is sorted in Date Added "
IF Desc Then
  Summary=Summary & "(descending) order."
Else
  Summary=Summary & "(ascending) order."
End If

Dim T3,T4               ' Extra timing for mystery delay on closing progress bar


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

GetTracks               ' Set things up
SortTracks    	        ' 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 main SortTracks module and supporting numerous options for track selection, confirmation, progress and results.


' Test ability to update track and retry until able or for 10 attempts
' Modified 2012-02-20
Sub Retry(T,PC)
  Dim R,S
  R=0
  On Error Resume Next
  Do
    R=R+1
    ' If there has been an error, pause & reset
    If Err.Number<>0 Then WScript.Sleep 100 : Err.Clear
    ' Catch potential exception from next statement
    T.PlayedCount=PC
  Loop Until Err.Number=0 Or R>9
  If Err.Number<>0 Then
    S="Repeated error &" & Hex(Err.Number) & " while attempting to update track info." & nl & nl
    S=S & "Giving up after " & R & " attempt" & Plural(R,"s!","!")
    MsgBox S,0,Title
    WScript.Quit
' Else
'   MsgBox "Property set after " & R & " attempt" & Plural(R,"s.","."),0,Title
  End If
End Sub

' Return SortAlbum, coping with empty values
' Modified 2012-07-14
Function SortAlbum(T)
  If T.SortAlbum & ""<>"" Then
    SortAlbum=T.SortAlbum
  ElseIf T.Album & ""<>"" Then
    SortAlbum=SortName(T.Album)
  Else
    SortAlbum="Unknown Album"
  End If
End Function


' Return SortAlbumArtist, coping with empty values
' Modified 2012-07-14
Function SortAlbumArtist(T)
  If T.Compilation Then
    SortAlbumArtist="Compilations"
  ElseIf T.SortAlbumArtist & ""<>"" Then
    SortAlbumArtist=T.SortAlbumArtist
  ElseIf T.AlbumArtist & ""<>"" Then
    SortAlbumArtist=SortName(T.AlbumArtist)
  ElseIf T.SortArtist & ""<>"" Then
    SortAlbumArtist=T.SortArtist
  ElseIf T.Artist & ""<>"" Then
    SortAlbumArtist=SortName(T.Artist)
  Else
    SortAlbumArtist="Unknown Artist"
  End If
End Function


' Return padded DiscNumber
' Modified 2012-07-14
Function SortDiscNumber(T)
  SortDiscNumber=Right("0" & T.DiscNumber,2)
End Function


' 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


' Return padded TrackNumber
' Modified 2012-07-14
Function SortTrackNumber(T)
  SortTrackNumber=Right("00" & T.TrackNumber,3)
End Function


' Sort a selection of tracks into date added order
' Modified 2011-10-10
Sub SortTracks
  Dim A,C,I,J,R,T,Swapped,Track,Temp,Path(),High(),Low()
  ReDim Path(Count),High(Count),Low(Count)
  TimeFactor=TZOffset
  If Prog Then Set PB=New ProgBar
  If Prog Then PB.Title=Title
  ' Note start time of operations
  If Timing Then Clock=0 : StartTimer
  J=0

  ' Read track data
  If Prog Then PB.SetStatus "Reading paths"
  If Prog Then PB.Show
  For I=1 To Count
    If Prog Then PB.Progress I,Count
    Set Track=Tracks.Item(I)
    If Track.Kind=1 Then
      If Track.Location="" Then
        M=M+1                   ' Increment missing tracks
        If Prog Then PB.SetDebug "<br>Missing file!" : WScript.Sleep 500      
      Else
        J=J+1
        'Path(J)=Track.Location
        'Path(J)=LCase(Track.Location)  ' Would correct for random casing inconsistency, however next line is better
        Path(J)=LCase(SortAlbumArtist(Track) & "\" & SortAlbum(Track) & "\" & SortDiscNumber(Track) & "-" & SortTrackNumber(Track) & " " & Track.Name)
        High(J)=iTunes.ITObjectPersistentIDHigh(Track)
        Low(J)=iTunes.ITObjectPersistentIDLow(Track)
      End If
    End If
  Next
  Count=J						            ' Reset count to number of "real" tracks.

  ' BubbleSort path & ids arrays into descending or ascending path order
  If Prog Then PB.SetStatus "Sorting"
  If Prog Then PB.Reset 
  If Count>1 Then
    Do
      Swapped=False
      For I=1 To Count-1
        If Prog Then PB.Step True
        If (Desc And Path(I)<Path(I+1)) Or (Not Desc And Path(I)>Path(I+1)) Then
          Temp=Path(I)
          Path(I)=Path(I+1)
          Path(I+1)=Temp
          Temp=High(I)
          High(I)=High(I+1)
          High(I+1)=Temp
          Temp=Low(I)
          Low(I)=Low(I+1)
          Low(I+1)=Temp
          Swapped=True
        End If
      Next
    Loop While Swapped
  End If
  
  ' Note current time
  LT=INT(Timer)

  ' Remove and reimport tracks in path order
  If Prog Then PB.Reset 
  For I=1 To Count
    If Quit Then Exit For
    Set Track=iTunes.LibraryPlaylist.Tracks.ItemByPersistentID(High(I),Low(I))
    If Prog Then PB.SetStatus "Processing " & I & " of " & Count
    If Prog Then PB.Progress I-1+.25,Count
    If Check Then               ' Track by track confirmation
      With Track
        T="Update?" & nl & nl & "Artist" & tab & ": " &.Artist & nl & "Album" & tab & ": " &.Album & nl _ 
          & "Name" & tab & ": " &.Name & nl & "Track #" & tab & ": " &.TrackNumber
      End With    
      StopTimer                 ' Don't time user inputs 
      R=MsgBox(T,vbYesNoCancel+vbQuestion,Title)
      StartTimer
      Select Case R
      Case vbYes
        C=True
      Case vbNo
        C=False
        S=S+1                   ' User skipped this track
      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
      UpdateTrack High(I),Low(I),I-1
    End If
    If Prog Then PB.Progress I,Count
    P=P+1                       ' Increment processed tracks
  Next

  If Timing Then StopTimer
  If Prog Then WScript.Sleep 500 : PB.Close
  T3=Timer
End Sub


' Remove, then reimport track and restore all metadata not stored in the tag
' Modified 2012-07-14
Sub UpdateTrack(H,L,N)
  Dim D,I,Path,Playlists,Track,Status,Ext,R,S,Z
  Dim AA,AL,AR,ARK,BT,CN,CP,CT,DC,DE,DN,EI,EN,EP,EQ,ES,FT,GE,GR,NA,PC,PD,PG
  Dim RA,RT,RAK,RB,RTK,SAA,SAL,SAR,SC,SCP,SD,SH,SSH,SN,SNA,ST,TC,TD,TN,UN,VA,VK,YR
  Set Track=iTunes.LibraryPlaylist.Tracks.ItemByPersistentID(H,L)

  With Track 
    If Prog Then
      PB.Progress N+.25,Count
      D=.Name & " by " & .Artist & "<br>"
      PB.SetInfo D & "Saving data"
      WScript.Sleep 100
    End If
    Path=.Location
    Ext=LCase(Right(Path,4))

    ' Record volatile metadata here, all file types
    EN=.Enabled
    UN=.Unplayed
    RA=.AlbumRating
    RAK=.AlbumRatingKind
    RT=.Rating
    RTK=.RatingKind
    ' Record extra data for files without tags
    If Instr("mpeg.mid.mov.mpg.pdf.wav",Ext)>0 Then
      TN=.TrackNumber
      TC=.TrackCount
      DN=.DiscNumber
      DC=.DiscCount
      YR=.Year
      CN=.Compilation
      PG=.PartOfGaplessAlbum
      NA=.Name
      AR=.Artist
      AA=.AlbumArtist
      AL=.Album
      CP=.Composer
      CT=.Comment
      GE=.Genre
      GR=.Grouping
    End If
    ' The AIF tag only records partial data, save the rest here, along with data for other non-tag formats
    If Instr("mpeg.aif.mid.mov.mpg.pdf.wav",Ext)>0 Then
      VK=.VideoKind
      SN=.SeasonNumber
      EP=.EpisodeNumber
      EI=.EpisodeID
      SH=.Show
      DE=.Description
      SNA=.SortName
      SAR=.SortArtist
      SAA=.SortAlbumArtist
      SAL=.SortAlbum
      SCP=.SortComposer
      SSH=.SortShow
    End If
    ' Record extra data for media file types
    If Instr("itlp.ite.pdf",Ext)=0 Then
      PC=.PlayedCount
      PD=.PlayedDate
      SC=.SkippedCount
      SD=.SkippedDate
      VA=.VolumeAdjustment
      EQ=.EQ
      ST=.Start
      FT=.Finish
      TD=.Duration
      RB=.RememberBookmark
      BT=.BookmarkTime
      ES=.ExcludeFromShuffle
    End IF

    ' Note playlist membership 
    Set Playlists=.Playlists
  End With
   
  ' Delete the track from the library
  If Prog Then
    PB.Progress N+.5,Count
    PB.SetInfo D & "Saving data - Removing file"
    WScript.Sleep 100
  End If
  StartEvent
  Track.Delete
  StopEvent
  
  ' Ensure at least 1 second has passed since last track was added
  Do
  Loop Until Int(Timer)<>LT			' Use <> in case of timer reset at midnight...

  ' Reimport the track into the library
  If Prog Then
    PB.Progress N+.75,Count
    PB.SetInfo D & "Saving data - Removing file - Adding file" 
    WScript.Sleep 100
  End If
  StartEvent
  Set Status=iTunes.LibraryPlaylist.AddFile(path)
  StopEvent
  
  ' Note current time
  LT=INT(Timer)

  If IsNull(Status) Then
    MsgBox "There was a problem reimporting the file " & nl & path,0,Title
  Else
    Do While Status.InProgress
      WScript.Sleep 100
    Loop
    If Status.Tracks.Count=0 Then MsgBox "No track!"
    Set Track=Status.Tracks(1)
   
    If Prog Then
      PB.Progress N+1,Count
      PB.SetInfo D & "Saving data - Removing file - Adding file - Restoring data"
      WScript.Sleep 100
    End If
    
    ' Reinsert track into non-smart user playlists
    StartEvent
    For I=1 To Playlists.Count
      If Playlists.Item(I).Kind=2 And Playlists.Item(I).Smart=False Then
        'MsgBox Playlists.Item(I).Name     
        Playlists.Item(I).AddTrack(Track)
      End If
    Next

    ' Restore volatile meta data here
    With Track
      ' Restore stats/playback options for media files only
      If Instr("itlp.ite.pdf",Ext)=0 Then
        '.PlayedCount=PC
        Retry Track,PC  ' Try to set PlayedCount property, loop until successful...
        ' Ignore potential errors while setting various media track properties
        On Error Resume Next
        If PD>0 Then .PlayedDate=DateAdd("n",TimeFactor*60,PD)
        .SkippedCount=SC
        If SD>0 Then .SkippedDate=DateAdd("n",TimeFactor*60,SD)
        .VolumeAdjustment=VA
        If EQ<>"" Then .EQ=EQ
        .Start=ST
        If TD>FT Then .Finish=FT
        If RB Then
          .RememberBookmark=RB
          .BookmarkTime=BT
        End If
        .ExcludeFromShuffle=ES
        'S=1/0   'Dummy error for testing
        If Err.Number<>0 Then
          S="An error occured while restoring a property of:" & nl & .location & nl & nl
          S=S & "Error:" & tab & Err.Description & nl
          S=S & "Code:" & tab & Right("0000000" & Err.Number,8) & nl & nl
          S=S & "Press OK to resume or Cancel to abort."
          ' Comment out the following line to ignore all errors in this section
          R=MsgBox(S,vbOKCancel+vbInformation,Title) : If R=vbCancel Then Quit=True
          Err.Clear
        End If
        ' Restore normal error handling
        On Error Goto 0
        
      End If
      ' Restore general iTunes specific/non-tag data
      .Enabled=EN
      .Unplayed=UN
      If RAK=0 Then .AlbumRating=RA     ' Don't restore computed ratings 
      If RTK=0 Then .Rating=RT          ' Don't restore computed ratings 
      ' Restore extra data for files without tags
      If Instr("mpeg.mid.mov.mpg.pdf.wav",Ext)>0 Then
        .TrackNumber=TN
        .TrackCount=TC
        .DiscNumber=DN
        .DiscCount=DC
        .Year=YR
        .Compilation=CN
        If ext=".wav" Then .PartOfGaplessAlbum=PG
        If NA<>"" Then .Name=NA
        If AR<>"" Then .Artist=AR
        If AA<>"" Then .AlbumArtist=AA
        If AL<>"" Then .Album=AL
        If CP<>"" Then .Composer=CP
        If CT<>"" Then .Comment=CT
        If GE<>"" Then .Genre=GE
        If GR<>"" Then .Grouping=GR
      End If
      ' The AIF tag only records partial data, restore the rest here, along with data for other non-tag formats
      If Instr("mpeg.aif.mid.mov.mpg.pdf.wav",ext)>0 Then
        ' MsgBox "VideoKind = " & VK
        If VK>0 Then .VideoKind=VK
        If ext<>".pdf" THEN .SeasonNumber=SN	' Can't set these two values for PDF's from script
        If ext<>".pdf" THEN .EpisodeNumber=EP	' although they can be set via iTunes Get Info. :(
        If EI<>"" Then .EpisodeID=EI
        If SH<>"" Then .Show=SH
        If DE<>"" Then .Description=DE
        If SNA<>"" Then .SortName=SNA
        If SAR<>"" Then .SortArtist=SAR
        If SAA<>"" Then .SortAlbumArtist=SAA
        If SAL<>"" Then .SortAlbum=SAL
        If SCP<>"" Then .SortComposer=SCP
        If SSH<>"" Then .SortShow=SSH
      End If
    End With
    StopEvent

    U=U+1                       ' Increment processed tracks
  End If
End Sub


' Get active time zone offset from GMT
' Modified 2011-10-04
Function TZOffset
  Dim Shell
  Set Shell=CreateObject("WScript.Shell") 
  TZOffset=Shell.RegRead("HKEY_LOCAL_MACHINE\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")/60
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
' ==============