' =================
' ExportImportPlays
' =================
' Version 1.0.0.28 - April 8th 2022
' Copyright © Steve MacGuire 2011-2022
' http://samsoft.org.uk/iTunes/ExportImportPlays.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
' ===========
' Allows for export of metadata from an iTunes library to a text file and subsequent import of the data
' Suggested uses are to roll forward lost stats from an older library or allow external editing of data

' Related scripts: ExportImport, ExportImportAltKey, ExportImportPlays, ExportImportRatings

' Output file structure, each line is blank or begins with a token
' <#>         Comment
' <ID>        LibraryPersistentID
' <Genre>     Genre
' <Plays>     Play Count
' <Played>    Last Played
' <Rating>    Rating
' <Skips>     Skip Count
' <Skipped>   Last Skipped
' Extend scheme as required

' On import blank lines & comments are ignored
' <ID> sets up the track to which subsequent values are applied until a new <ID> is given


' =========
' ChangeLog
' =========
' Version 1.0.0.1 - Initial version
' Version 1.0.0.2 - Added support for rating & album rating, current version exports ratings & play/skip counts/dates
' Version 1.0.0.3 - Added support for name & composer
' Version 1.0.0.4 - Added more fields, use Unicode output/input, fixed error in ObjectByID
' Version 1.0.0.5 - Minor update to common code
' Version 1.0.0.6 - Add support for comments field
' Version 1.0.0.7 - Add support for BPM, EQ, VolumeAdjustment, Lyrics, Start,& Finish
' Version 1.0.0.8 - Fix for potential UAC error in import routine
' Version 1.0.0.9 - Tweak to Info routine
' Version 1.0.0.10 - Added fields and change to export filenames
' Version 1.0.0.11 - Tweaks for default exported data and to ignore read-only data on import
' Version 1.0.0.12 - Added facility for alternate key when exporting & importing, e.g. size in bytes which will often be unique
'                  - See https://discussions.apple.com/thread/8448297 for more
' Version 1.0.0.13 - Added bug hunting code for unexpected error reading AlbumRating property
'                  - See https://discussions.apple.com/thread/250526272
' Version 1.0.0.14 - Tweaks for play and skip imports, new AddToOldPlays and OpenExport flags
' Version 1.0.0.15 - Allow export from connected device. Contains tweaked versions of GetTracks and ProcessTracks
' Version 1.0.0.16 - Add in an option to export and import artwork
'                  - See https://discussions.apple.com/thread/251735468 for genesis of this update 
' Version 1.0.0.17 - Automatically relink if file has been replaced by and alternate format, e.g. <Filename>.mp3 replaced by <Filename>.m4a      
' Version 1.0.0.18 - Add feature to force update of values, always, or after relinking. Ignored for .wav files since iTunes doesn't write/update the tag
' Version 1.0.0.19 - Saved artwork now goes in a separate Artwork folder to keep things tidy
' Version 1.0.0.20 - Force art to be embedded as iTunes doesn't report current state of tag
' Version 1.0.0.21 - Minor edit to generated filenames
' Version 1.0.0.22 - Minor edit to fix typo
' Version 1.0.0.23 - Improved artwork code to avoid embedding multiple images
' Version 1.0.0.24 - Now allows DateAdded to be modified
' Version 1.0.0.25 - Fix artwork insert bug for non-existent or .wav files when relimking updated tracks
' Version 1.0.0.26 - Count files where location was not fixed
' Version 1.0.0.27 - Updated code for AltKey imports
' Version 1.0.0.28 - Fix typo in some versions of script and republish with common codebase


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

' =============================
' Declare constants & variables
' =============================
' Core values for reusable code
' Modified 2014-04-06
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 processing 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 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


' =======================
' Initialise user options
' =======================
' Custom values for this script
' Modified 2020-09-06
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 in summary report
Named=False             ' Force script to process specific playlist rather than current selection or playlist
Rev=False               ' Control processing order, usually reversed
Source=""               ' Named playlist to process, use "Library" for entire library
Tracing=True            ' Display/suppress tracing messages

Title="Export Import - Export Mode"
Summary="Export or import iTunes metadata" & vbCrLf & vbCrLf

' Additional variables for this particular script
' Modified 2021-01-07
Dim AddToOldPlays,AltKey,Artwork,CheckTime,IgnoreExt,K,KD,Keys,KT,LC,ML
Dim File,Force,FSO,Path,Open,OpenExport,WshShell,nlRep,Mode

' Initialise variables for this particular script
' Modified 2021-01-07
AddToOldPlays=False     ' Use to add current low recent plays to larger historic values, repeat import shouldn't grow values
AltKey=False            ' Use where PersistentID won't be the same
Open=False              ' Flag for output control
OpenExport=True         ' Open exported text file
nlRep=" \n "            ' Text string to represent new line in exported/imported data
Artwork=True            ' Save artwork on export
CheckTime=False         ' Check system time if clock has been altered
Force=False             ' Force all properties to be updated during import, implied if location is changed
IgnoreExt=True          ' Ignore extension


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

If WScript.Arguments.Count>1 Then
  MsgBox "Drag a single .txt file onto this script to import metadata.",vbCritical,Title
  WScript.Quit
ElseIf WScript.Arguments.Count=1 Then
  Mode="Import"
  Title="Export Import - Import Mode"
  ImportFile
Else
  Mode="Export"
  Summary=Summary & "Export mode: For import drag & drop a text file onto this script." & vbCrLf & vbCrLf
  Summary=Summary & "Please temporarily rename the media folder before exporting data if you are trying to export the "
  Summary=Summary & "old values of metadata that have been corrupted from an older copy of your library database."
  GetTracks             ' Set things up
  ProcessTracks 	    ' Main process
  If Open Then          ' Close file if open
    File.Close
    If OpenExport Then WshShell.Run """" & Path  & """"
  End If
  Result                ' Summary
End If

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


' Export selected data fields to text file
' Modified 2020-09-01
Sub Action(T)
  Dim Art
  If Not Open Then OutputFile("ExportImport")
  With T

    StartEvent          ' Time potentially slow event
    ' Extend exported info as required
    File.WriteLine ""
    File.WriteLine "<ID>" & PersistentID(T)                     ' Must include this property, usually Library Persistent ID
    If AltKey Then File.WriteLine "<AltKey>" & Signature(T)     ' Alternate key for matching when <ID> doesn't
    File.WriteLine "<#>" & KeyText(T)                           ' Save key text details as a comment so output can be interpreted
    
    ' Comment out details you want to omit, remove the quote to include
    ' WriteLine "<Location>" & .Location          ' Won't export a path for missing tracks
    ' WriteLine "<DateAdded>" & .DateAdded
    ' WriteLine "<Name>" & .Name
    ' WriteLine "<SortName>" & SortValue(.Name,.SortName)
    ' WriteLine "<Album>" & .Album 
    ' WriteLine "<SortAlbum>" & SortValue(.Album,.SortAlbum)
    ' WriteLine "<AlbumArtist>" & .AlbumArtist
    ' WriteLine "<SortAlbumArtist>" & SortValue(.AlbumArtist,.SortAlbumArtist)
    ' WriteLine "<Artist>" & .Artist
    ' WriteLine "<SortArtist>" & SortValue(.Artist,.SortArtist)
    ' WriteLine "<Composer>" & .Composer
    ' WriteLine "<SortComposer>" & SortValue(.Composer,.SortComposer) 
    ' WriteLine "<Grouping>" & .Grouping
    ' WriteLine "<Genre>" & .Genre
    ' WriteLine "<Compilation>" & .Compilation
    ' WriteLine "<DiscNumber>" & .DiscNumber
    ' WriteLine "<DiscCount>" & .DiscCount
    ' WriteLine "<TrackNumber>" & .TrackNumber
    ' WriteLine "<TrackCount>" & .TrackCount
    ' WriteLine "<Year>" & .Year
    WriteLine "<Plays>" & .PlayedCount
    ' WriteLine "<Played>" & .PlayedDate
    WriteLine "<Skips>" & .SkippedCount
    ' WriteLine "<Skipped>" & .SkippedDate
    ' WriteLine "<Checked>" & .Enabled
    ' WriteLine "<Comment>" & Replace(.Comment,nl,nlRep)
    ' WriteLine "<Description>" & Replace(.Description,nl,nlRep)
    ' WriteLine "<LongDescription>" & Replace(.LongDescription,nl,nlRep)
    ' WriteLine "<Lyrics>" & Replace(.Lyrics,nl,nlRep)
    ' WriteLine "<BitRate>" & .BitRate
    ' WriteLine "<KindAsString>" & .KindAsString
    ' WriteLine "<BPM>" & .BPM
    ' WriteLine "<EQ>" & .EQ
    ' WriteLine "<VA>" & .VolumeAdjustment
    ' WriteLine "<Start>" & .Start
    ' WriteLine "<Finish>" & .Finish
    ' WriteLine "<ExcludeFromShuffle>" & .ExcludeFromShuffle
    ' If .RememberBookmark Then WriteLine "<RememberBookmark>" & .RememberBookmark
    ' WriteLine "<BookmarkTime>" & .BookmarkTime  
    ' If .AlbumRatingKind=0 Then WriteLine "<AlbumRating>" & .AlbumRating    ' Don't export autoratings
    ' If .RatingKind=0 Then WriteLine "<Rating>" & .Rating                   ' Don't export autoratings
    ' If .Show & ""<>"" Then WriteLine "<Show>" & .Show : WriteLine "<SortShow>" & SortValue(.Show,.SortShow) : WriteLine "<Season>" & .SeasonNumber : WriteLine "<Episode>" & .EpisodeNumber : WriteLine "<EpisodeID>" & .EpisodeID
    If Artwork Then     ' Optionally save artwork
      Art=SaveArt(T)
      If Art<>"" Then
        WriteLine "<Artwork>" & Art
      End If
    End If
    StopEvent           ' Show event time
  End With
End Sub


' Description of an update
' Modified 2014-09-25
Function Change(A,B,C)
  Change="Changing" & tab & A & nl & "from" & tab
  If B="" Then Change=Change & "<Nothing>" Else Change=Change & B
  Change=Change & nl & "to" & tab
  If C="" Then Change=Change & "<Nothing>" Else Change=Change & C  
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


' Get alternate keys from current selection, playlist or library
' Modified 2021-01-07
Sub GetKeys
  Dim I,Key,T,Tracks
  ' Get current selection, recycled from GetTracks
  Source="Library"                      ' Force indexing of library rather than selection
  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
  K=0 : KD=0
  Set Keys=CreateObject("Scripting.Dictionary")
  '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
  ' Got current selection, or playlist, or library
  For Each T in Tracks
    If T.Kind=1 Then
      If T.Location<>"" Then                ' Ignore unavailable/cloud items
        Key=Signature(T)
        If Not Keys.Exists(Key) Then
          Keys.Add Key, PersistentID(T)     ' Add ID for item with key
          ' Trace T,"Adding key:" & nl & "Key" & tab & Key & nl & "Value" & tab & Keys.Item(Key) ' & nl & KeyText(T)
          K=K+1
        Else
          If KD<3 Then StopTimer : Trace T,"Found a dupe:" & nl & "Item 1=" & Keys.Item(Key) & nl & "Key=" & Key & nl & KeyText(ObjectFromID(Keys.Item(Key))) & nl & nl & "Item 2=" & PersistentID(T) & nl & "Key=" & Key & nl & KeyText(T) : StartTimer
          If Keys.Item(Key)<>"" Then Keys.Item(Key)="" : K=K-1 : KD=KD+1  ' Remove path if key isn't unique, decrement unique count, increment dupe count
          KD=KD+1                           ' Increment dupe count
        End If
      End If
    End If
  Next
  ' MsgBox "GetKeys found " & GroupDig(K) & " keys.",0,Title 
  If KD>0 Then MsgBox "There were " & KD & " items with duplicate keys whose metadata may need rebuilding by hand.",0,Title
End Sub


' Import a text file of metadata
' Modified 2021-01-07
Sub ImportFile
  Dim Art,B,Base,C,Ext,F,I,L,Line,Loc,LV,Mode,NewFile,Offset,Playlists,Q,R,S,State,T,Token,Value
  ' Initialise global variables
  nl=vbCrLf : tab=Chr(9) : Quit=False
  D=0 : M=0 : P=0 : S=0 : U=0 : V=0 : ML=0
  ' Initialise global objects
  Set iTunes=CreateObject("iTunes.Application")
  Set FSO=CreateObject("Scripting.FileSystemObject")
  Path=WScript.Arguments.Item(0)
  C=0 : I=0 : LC=0
  If FSO.FileExists(Path)=False Then
    MsgBox "File not found!",vbCritical,Title
    WScript.Quit
  End If
  Set File=FSO.GetFile(Path)
  F=FSO.GetFileName(File)
  ' Pass 1 - Count the number of potential tracks to add
  Set File=FSO.OpenTextFile(Path,1,False,-1)	' Read only, don't create, Unicode
  Do While Not File.AtEndOfStream
    Line=Trim(File.ReadLine)
    If LCase(Left(Line,4))="<id>" Then
      ' If Prog Then PB.Step True
      C=C+1
    End If
    LC=LC+1
  Loop
  File.Close
  
' Confirmation dialogs
  If C=0 Then
    Q="The file " & F & " contains no valid entries!"
    MsgBox Q,vbCritical,Title
    WScript.Quit
  ElseIf Intro Then
    Q="Import metadata for " & GroupDig(C) & " item" & Plural(C,"s","") & "?"
    If Prog And UAC Then
      Q=Q & nl & nl & "NB: Use the EnableLUA script to allow the progress bar to function" & nl
      Q=Q & "or change the declaration ''Prog=True'' to ''Prog=False'' to hide this message. "
      Prog=False
    End If
    R=MsgBox(Q,vbOKCancel+vbQuestion,Title)
    If R=vbCancel or R=vbNo Then WScript.Quit
  ElseIf Prog And UAC Then
    Prog=False
  End If
  
  Count=C
  
  If Prog Then                  ' Create ProgessBar
    Set PB=New ProgBar
    PB.Show
  End If
  Clock=0 : StartTimer

  If AltKey Then GetKeys        ' Set up dictionay of alternate keys

  ' Pass 2 - Process file
  Mode=0                        ' Looking for a track ID
  Set File=FSO.OpenTextFile(Path,1,False,-1)	' Read only, don't create, Unicode
  Do While Not File.AtEndOfStream
    Line=Trim(File.ReadLine)
    B=Instr(Line,">")
    If Left(Line,1)="<" And B>0 Then
      Token=LCase(Left(Line,B))
      Value=Mid(Line,B+1)
      ' MsgBox "Token=" & Token & nl & "Value=" & Value,0,Title
      If Mode=0 Then            ' Waiting to get a valid working track
        If Token="<altkey>" and AltKey=False Then AltKey=True : GetKeys : M=M-1 ' Hack to ignore previous missing item      
        If (Not AltKey And Token="<id>") or (AltKey And Token="<altkey>") Then
          If Token="<altkey>" Then
            'Trace Null,"Mode=" & Mode & " - Getting item with key " & Value
            Set T=Nothing
            LV=LCase(Value)           ' Ignore case for keys
            If Keys.Exists(LV) Then 
              If Keys.Item(LV)<>"" Then Set T=ObjectFromID(Keys.Item(LV))
            End If
            If T is Nothing Then      ' Currently generating an error - need to improve AltKey mode
              'Trace Null,"There were no matches in the current selection for the item with alternate key " & nl & nl & Value & nl & nl & "Try again selecting items likely to match those from which data was exported or edit the AltKeys to create matches."
            End If            
          Else
            Set T=ObjectFromID(Value)
          End If
          If T Is Nothing Then
            If AltKey Then
              Trace T,"Unable to identify object with AltKey" & nl & nl & Value
            Else
              Trace T,"Unable to identify object with ID" & nl & nl & Value
            End If
            M=M+1
            Mode=0
          Else
            Mode=1              ' T is a valid track object, check if it can or should be forced to have properties updated
            If Force And T.Location<>"" And LCase(Right(T.Location,4))<>".wav" Then NewFile=True Else NewFile=False
            P=P+1                 
            If Prog Then
              PB.SetStatus Status(P)
              PB.Progress P,Count
              PB.SetInfo Info(T)
            End If
          End If
        End If
      Else                      ' Have a working track, update properties 
        Select Case Token
        Case "<altkey>","<id>"          ' Update working track
          If (Not AltKey And Token="<id>") or (AltKey And Token="<altkey>") Then
            If AltKey And Token="<altkey>" Then
              'Trace Null,"Mode=" & Mode & " - Getting item with key " & Value
              LV=LCase(Value)           ' Ignore case for keys
              If Keys.Exists(LV) Then Set T=ObjectFromID(Keys.Item(LV)) Else Set T=Nothing
              If T is Nothing Then
                Trace Null,"There were no matches in the current selection for the item with alternate key " & nl & Value & nl & "Try again selecting items likely to match those from which data was exported."
              End If           
            Else
              If Not AltKey And Token="<id>" Then Set T=ObjectFromID(Value)
            End If
            If T Is Nothing Then
              If AltKey Then
                Trace T,"Unable to identify object with AltKey" & nl & nl & Value
              Else
                Trace T,"Unable to identify object with ID" & nl & nl & Value
              End If
              Mode=0              		  ' T is not a valid track object, ignore all input until a new valid object found
              M=M+1
            Else
              Mode=1                    ' T is a valid track object, check if it can or should be forced to have properties updated
              If Force And T.Location<>"" And LCase(Right(T.Location,4))<>".wav" Then NewFile=True Else NewFile=False
              P=P+1                 
              If Prog Then
                PB.SetStatus Status(P)
                PB.Progress P,Count
                If Not AltKey Then PB.SetInfo Info(T)
              End If
            End If
          End If
        
        Case "<album>"
          If NewFile Or T.Album<>Value Then             ' Don't update if value won't change
            If NewFile Then T.Album=Value & "*"         ' Force iTunes to update tag
            Trace T,Change("Album",T.Album,Value)
            T.Album=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<albumartist>"
          If NewFile Or T.AlbumArtist<>Value Then       ' Don't update if value won't change
            If NewFile Then T.AlbumArtist=Value & "*"   ' Force iTunes to update tag
            Trace T,Change("AlbumArtist",T.AlbumArtist,Value)
            T.AlbumArtist=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<albumrating>"
          On Error Resume Next  ' Trap possible error
          Check=T.AlbumRating   ' Will cause an error if object doesn't have an AlbumRating property
          If Err.Number<>0 Then ' Handle error
            Trace T,"Error reading AlbumRating from object."
            V=V+1
          Else                  ' No error
            If T.AlbumRating<>Value+0 Then              ' Don't update if value won't change (add zero to prevent comparison errors)
              ' Trace T,Change("AlbumRating",T.AlbumRating,Value)
              T.AlbumRating=Value
              U=U+1
            Else
              V=V+1
            End If
          End If
          On Error Goto 0       ' Restore normal error handler 
        Case "<artist>"
          If NewFile Or T.Artist<>Value Then            ' Don't update if value won't change
            If NewFile Then T.Artist=Value & "*"        ' Force iTunes to update tag
            Trace T,Change("Artist",T.Artist,Value)
            T.Artist=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<artwork>"
          Set Art=T.Artwork
          If NewFile Or Art.Count=0 Then                ' Don't insert art if present, don't assume art count acurate if new file
            If FSO.FileExists(Value) And T.Location<>"" And LCase(Right(T.Location,4))<>".wav" Then   ' Check that adding art is viable
              Trace T,Change("Artwork","None",Value)
              T.AddArtworkFromFile(Value)               ' Should probably add an error handler here
              If Art.Count>1 Then Art(Art.Count).Delete ' Delete any extra art added in error because
              U=U+1
            Else
              V=V+1                                     ' Count as unchanged 
            End If
          Else
            V=V+1
          End If
        Case "<bitrate>","<kindasstring>"
          ' Do nothing, cannot update read only values 
          V=V+1                                 ' Count as unchanged
        Case "<bookmarktime>"
          If DateDiff("s",T.BookmarkTime,Value)<>0 Then         ' Don't update if value won't change
            Trace T,Change("BookmarkTime",T.BookmarkTime,Value)
            T.BookmarkTime=Value
            U=U+1
          Else
            V=V+1
          End If      
        Case "<bpm>"
          If NewFile Or T.BPM<>Value+0 Then     ' Don't update if value won't change (add zero to prevent comparison errors)
            If NewFile Then T.BPM=Value+1       ' Force iTunes to update tag
            Trace T,Change("BPM",T.BPM,Value)
            T.BPM=Value
            U=U+1
          Else
            V=V+1
          End If        
        Case "<checked>","<enabled>"
          Value=(Value="True")
          If T.Enabled<>Value Then              ' Don't update if value won't change
            Trace T,Change("Checked",T.Enabled,Value)
            T.Enabled=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<comment>"
          If NewFile Or T.Comment<>Replace(Value,nlRep,nl) Then         ' Don't update if value won't change
            If NewFile Then T.Comment=Replace(Value,nlRep,nl) & "*"     ' Force iTunes to update tag
            Trace T,Change("Comment",T.Comment,Replace(Value,nlRep,nl))
            T.Comment=Replace(Value,nlRep,nl)
            U=U+1
          Else
            V=V+1
          End If
        Case "<compilation>"
          Value=(Value="True")
          If NewFile Or T.Compilation<>Value Then       ' Don't update if value won't change
            If NewFile Then T.Compilation=Not Value     ' Force iTunes to update tagT.Compilation=Value
            Trace T,Change("Compilation",T.Compilation,Value)
            T.Compilation=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<composer>"
          If NewFile Or T.Composer<>Value Then		      ' Don't update if value won't change
            If NewFile Then T.Composer=Value & "*"      ' Force iTunes to update tag
            Trace T,Change("Composer",T.Composer,Value)
            T.Composer=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<dateadded>"
          If DateDiff("s",T.DateAdded,Value)<>0 Then    ' Don't update if value won't change
            Trace T,Change("DateAdded",T.DateAdded,Value)
            Loc=T.Location
            ' Offset=DateDiff("s",Now,Value) : MsgBox "New date added value: " & Value & nl & nl & "Add code to remove the file " & nl & nl & Loc & nl & "then change date by " & GroupDig(Offset) & " seconds, to " & nl & nl & UTC(Value) & nl & nl & "then add back the file, and restore the date to " & nl & nl & UTC(DateAdd("s",-Offset,Value)) & nl & nl & "See SortDateAdded script for playlist save and restore routine",0,Title
            If Loc="" Then                              ' Don't try to correct date added for missing files
              V=V+1
            Else
              Set Playlists=T.Playlists                         ' Note playlist membership 
              CheckTime=True                                    ' Flag up that times have been modified
              T.Delete                                          ' Remove item from library
              Offset=DateDiff("s",Now,Value)                    ' Update offset between now and then
              SetUTC UTC(Value)                                 ' Set clock back to tnen
              Set State=iTunes.LibraryPlaylist.AddFile(Loc)     ' Add the file back to the library
              If IsNull(State) Then
                MsgBox "There was a problem reimporting the file " & nl & Loc,0,Title
                ' What happens to system clock here if user aborts?
              Else
                Do While State.InProgress                       ' Wait for import to complete
                  WScript.Sleep 100
                Loop
                ' If State.Tracks.Count=0 Then MsgBox "No track!",0,Title       ' Assume this isn't a possibility
                Set T=State.Tracks(1)                           ' Repair the pointer to the track
              End If
              SetUTC UTC(DateAdd("s",-Offset,Now))              ' Restore the current time by adding offset to current now
              For L=1 To Playlists.Count                        ' Add tracks back to its playlists, note position is not restored
                If Playlists.Item(L).Kind=2 And Playlists.Item(L).Smart=False Then
                  Playlists.Item(L).AddTrack(T)                 ' MsgBox "Adding track to " & Playlists.Item(L).Name,0,Title                    
                End If
              Next
              U=U+1
            End If
          Else
            V=V+1
          End If
        Case "<description>"
          If NewFile Or T.Description<>Replace(Value,nlRep,nl) Then     ' Don't update if value won't change
            If NewFile Then T.Description=Replace(Value,nlRep,nl) & "*" ' Force iTunes to update tag
            Trace T,Change("Description",T.Description,Replace(Value,nlRep,nl))
            T.Description=Replace(Value,nlRep,nl)
            U=U+1
          Else
            V=V+1
          End If
        Case "<disccount>"
          If NewFile Or T.DiscCount<>Value+0 Then       ' Don't update if value won't change (add zero to prevent comparison errors)
            If NewFile Then T.DiscCount=Value+1         ' Force iTunes to update tag
            Trace T,Change("DiscCount",T.DiscCount,Value)
            T.DiscCount=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<discnumber>"
          If NewFile Or T.DiscNumber<>Value+0 Then      ' Don't update if value won't change (add zero to prevent comparison errors)
            If NewFile Then T.DiscNumber=Value+1        ' Force iTunes to update tag
            Trace T,Change("DiscNumber",T.DiscNumber,Value)
            T.DiscNumber=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<episode>"
          If NewFile Or T.EpisodeNumber<>Value+0 Then   ' Don't update if value won't change (add zero to prevent comparison errors)
            If NewFile Then T.EpisodeNumber=Value+1     ' Force iTunes to update tag
            Trace T,Change("EpisodeNumber",T.EpisodeNumber,Value)
            T.EpisodeNumber=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<episodeid>"
          If NewFile Or T.EpisodeID<>Value Then         ' Don't update if value won't change
            If NewFile Then T.EpisodeID=Value & "*"     ' Force iTunes to update tag
            Trace T,Change("EpisodeID",T.EpisodeID,Value)
            T.EpisodeID=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<eq>"
          If (T.EQ & "")<>Value Then		                ' Don't update if value won't change
            Trace T,Change("EQ",T.EQ,Value)
            T.EQ=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<excludefromshuffle>"
          Value=(Value="True")
          If T.ExcludeFromShuffle<>Value Then           ' Don't update if value won't change
            Trace T,Change("ExcludeFromShuffle",T.ExcludeFromShuffle,Value)
            T.ExcludeFromShuffle=Value
            U=U+1
          Else
            V=V+1
          End If  
        Case "<finish>"
          ' Possible rounding issue with export value exceeding max. time? Could setting this also trrm time. Ingore for safety.
          V=V+1
          'If T.Finish<>Value+0 Then                     ' Don't update if value won't change (add zero to prevent comparison errors)
          '  Trace T,Change("Finish",T.Finish,Value)
          '  T.Finish=Value                                
          '  U=U+1
          'Else
          '  V=V+1
          'End If
        Case "<genre>"
          If NewFile Or T.Genre<>Value Then              ' Don't update if value won't change
            If NewFile Then T.Genre=Value & "*"          ' Force iTunes to update tag
            Trace T,Change("Genre",T.Genre,Value)
            T.Genre=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<grouping>"
          If NewFile Or T.Grouping<>Value Then          ' Don't update if value won't change
            If NewFile Then T.Grouping=Value & "*"      ' Force iTunes to update tag
            Trace T,Change("Grouping",T.Grouping,Value)
            T.Grouping=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<location>"
          If T.Location="" And Value<>"" Then           ' Only attempt a fix if broken
            Loc=Value
            If Not FSO.FileExists(Value) Then           ' Find a file in the same folder with a different extension
              Base=Left(Loc,Len(Loc)-Len(FSO.GetExtensionName(Loc)))
              For Each Ext in Array("m4a","mp3","aif","aiff","wav")
                If FSO.FileExists(Base & Ext) Then
                  Loc=Base & Ext
                  Exit For
                End If
              Next  
            End If
            If FSO.FileExists(Loc) Then
              Trace T,Change("Location",T.Location,Wrap(Loc,60,"\",1))
              T.Location=Loc
              If LCase(Right(Loc,4))=".wav" Then NewFile=False Else NewFile=True ' After relinking iTunes may hold stale version of tag which needs overwriting
              U=U+1
            Else
              Trace T,Change("Unable to update location",T.Location,Wrap(Loc,60,"\",1))
              NewFile=False                                                     ' No point forcing updates if there isn't a tag to write them in
              V=V+1
              ML=ML+1
            End If
          Else
            V=V+1
          End If
        Case "<longdescription>"
          If NewFile Or T.LongDescription<>Replace(Value,nlRep,nl) Then         ' Don't update if value won't change
            If NewFile Then T.LongDescription=Replace(Value,nlRep,nl) & "*"     ' Force iTunes to update tag
            Trace T,Change("LongDescription",T.LongDescription,Replace(Value,nlRep,nl))
            T.LongDescription=Replace(Value,nlRep,nl)
            U=U+1
          Else
            V=V+1
          End If
        Case "<lyrics>"
          If T.Location="" Or T.KindAsString="WAV audio file" Then
            V=V+1                                       ' Cannot read lyrics for missing item or .wav files
          Else  
            If T.Lyrics<>Replace(Value,nlRep,nl) Then   ' Don't update if value won't change
              Trace T,Change("Lyrics",T.Lyrics,Replace(Value,nlRep,nl))
              T.Lyrics=Replace(Value,nlRep,nl)
              U=U+1
            Else
              V=V+1
            End If
          End If
        Case "<name>"
          If NewFile Or T.Name<>Value Then              ' Don't update if value won't change
            If NewFile Then T.Name=Value & "*"          ' Force iTunes to update tag
            Trace T,Change("Name",T.Name,Value)
            T.Name=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<played>","<playeddate>"
          If DateDiff("s",T.PlayedDate,Value)>0 Then    ' Only update if newer
            Trace T,Change("PlayedDate",T.PlayedDate,Value)
            T.PlayedDate=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<plays>","<playedcount>"
          If AddToOldPlays Then
            If T.PlayedCount<Value+0 Then       ' If value has decreased (add zero to prevent comparison errors)
              Trace T,Change("Adding To PlayedCount",T.PlayedCount,Value)
              T.PlayedCount=T.PlayedCount+Value   ' add historic value to current
              U=U+1
            Else
              V=V+1
            End If
          Else
            If T.PlayedCount<>Value+0 Then      ' If value is different (add zero to prevent comparison errors)
              Trace T,Change("PlayedCount",T.PlayedCount,Value)
              T.PlayedCount=Value                ' replace with historic value
              U=U+1
            Else
              V=V+1
            End If
          End If
        Case "<rating>"
          If T.Rating<>Value+0 Then             ' Don't update if value won't change (add zero to prevent comparison errors)
            Trace T,Change("Rating",T.Rating & "%",Value & "%")
            T.Rating=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<rememberbookmark>"
          Value=(Value="True")
          If T.RememberBookmark<>Value Then     ' Don't update if value won't change
            Trace T,Change("RememberBookmark",T.RememberBookmark,Value)
            T.RememberBookmark=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<season>"
          If NewFile Or T.SeasonNumber<>Value+0 Then    ' Don't update if value won't change (add zero to prevent comparison errors)
            If NewFile Then T.SeasonNumber=Value+1      ' Force iTunes to update tag
            Trace T,Change("SeasonNumber",T.SeasonNumber,Value)
            T.SeasonNumber=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<show>"
          If NewFile Or T.Show<>Value Then    	        ' Don't update if value won't change
            If NewFile Then T.sHOW=Value & "*"          ' Force iTunes to update tag
            Trace T,Change("Show",T.Show,Value)
            T.Show=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<skipped>","<skippeddate>"
          If DateDiff("s",T.SkippedDate,Value)>0 Then           ' Only update if newer
            Trace T,Change("SkippedDate",T.SkippedDate,Value)
            T.SkippedDate=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<skips>","<skippedcount>"
          If AddToOldPlays Then
            If T.SkippedCount<Value+0 Then          ' If value has decreased (add zero to prevent comparison errors)
              Trace T,Change("Adding To Skips",T.SkippedCount,Value)            
              T.SkippedCount=T.SkippedCount+Value   ' add historic value to current
              U=U+1
            Else
              V=V+1
            End If
          Else
            If T.SkippedCount<>Value+0 Then         ' If value is different (add zero to prevent comparison errors)
              Trace T,Change("Skips",T.SkippedCount,Value)            
              T.SkippedCount=Value                  ' replace with historic value
              U=U+1
            Else
              V=V+1
            End If
          End If
        Case "<sortalbum>"
          If NewFile Or SortValue(T.Album,T.SortAlbum)<>Value Then              ' Don't update if value won't change
            If NewFile Then T.SortAlbum=Value & "*"                             ' Force iTunes to update tag
            Trace T,Change("SortAlbum",T.SortAlbum,Value)
            T.SortAlbum=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<sortalbumartist>"
          If NewFile Or SortValue(T.AlbumArtist,T.SortAlbumArtist)<>Value Then  ' Don't update if value won't change
            If NewFile Then T.SortAlbumArtist=Value & "*"                       ' Force iTunes to update tag
            Trace T,Change("SortAlbumArtist",T.SortAlbumArtist,Value)
            T.SortAlbumArtist=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<sortartist>"
          If NewFile Or SortValue(T.Artist,T.SortArtist)<>Value Then				    ' Don't update if value won't change
            If NewFile Then T.SortArtist=Value & "*"                            ' Force iTunes to update tag
            Trace T,Change("SortArtist",T.SortArtist,Value)
            T.SortArtist=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<sortcomposer>"
          If NewFile Or SortValue(T.Composer,T.SortComposer)<>Value Then        ' Don't update if value won't change
            If NewFile Then T.SortComposer=Value & "*"                          ' Force iTunes to update tag
            Trace T,Change("SortComposer",T.SortComposer,Value)
            T.SortComposer=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<sortname>"
          If NewFile Or SortValue(T.Name,T.SortName)<>Value Then    	       		' Don't update if value won't change
            If NewFile Then T.SortName=Value & "*"                              ' Force iTunes to update tag
            Trace T,Change("SortName",T.SortName,Value)
            T.SortName=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<sortshow>"
          If NewFile Or SortValue(T.Show,T.SortShow)<>Value Then    	       		' Don't update if value won't change
            If NewFile Then T.SortShow=Value & "*"                              ' Force iTunes to update tag
            Trace T,Change("SortShow",T.SortShow,Value)
            T.SortShow=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<start>"
          If T.Start<>Value+0 Then                      ' Don't update if value won't change (add zero to prevent comparison errors)
            Trace T,Change("Start",T.Start,Value)
            T.Start=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<trackcount>"
          If NewFile Or T.TrackCount<>Value+0 Then      ' Don't update if value won't change (add zero to prevent comparison errors)
            If NewFile Then T.TrackCount=Value+1        ' Force iTunes to update tag
            Trace T,Change("TrackCount",T.TrackCount,Value)
            T.TrackCount=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<tracknumber>"
          If NewFile Or T.TrackNumber<>Value+0 Then     ' Don't update if value won't change (add zero to prevent comparison errors)
            If NewFile Then T.TrackNumber=Value+1       ' Force iTunes to update tag
            Trace T,Change("TrackNumber",T.TrackNumber,Value)
            T.TrackNumber=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<va>"
          If T.VolumeAdjustment<>Value+0 Then          ' Don't update if value won't change (add zero to prevent comparison errors)
            Trace T,Change("VolumeAdjustment",T.VolumeAdjustment,Value)
            T.VolumeAdjustment=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<year>"
          If NewFile Or T.Year<>Value+0 Then            ' Don't update if value won't change (add zero to prevent comparison errors)
            If NewFile Then T.Year=Value+1              ' Force iTunes to update tag
            Trace T,Change("Year",T.Year,Value)
            T.Year=Value
            U=U+1
          Else
            V=V+1
          End If
        Case "<#>"
          ' Ignore comments
        Case Else
          ' Do nothing, ignore all invalid tokens
          Trace T,"Unknown token " & Token & nl & nl & "Edit the ImportFile subroutine to add support."
        End Select
      End If
    End If
    If Quit Then Exit Do
  Loop
  File.Close
  StopTimer
  If Prog And Not Quit Then
    PB.Progress Count,Count
    WScript.Sleep 250
  End If
  If Prog Then PB.Close
  Rundown
End Sub


' Custom info message for progress bar
' Modified 2018-07-08
Function Info(T)
  Dim A,B,R
  A="" : Info=""
  If T Is Nothing Then Exit Function
  With T
    On Error Resume Next
    A=.AlbumArtist & ""
    On Error Goto 0
    If A="" Then A=.Artist & "" : If A="" Then A="Unknown Artist"
    B=.Album & "" 
    If B="" Then B="Unknown Album"
    Info=Mode & "ing: " & A & " - " & B & " - " & .Name & ""
    If Err.Number>0 Then
      R=MsgBox("Problem with item " & .Name,vbOKCancel,Title)
      If R=vbCancel Then Quit=True
    End If
  End With
End Function


' Key track information 
' Modified 2018-10-17
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
    KT=KT & .Name
  End With
  KeyText=KT
End Function


' Create a text file for output, with title T & datestamp
' Modified 2019-09-19
Sub OutputFile(T)
  Dim Folder,N,S
  Set FSO=CreateObject("Scripting.FileSystemObject")
  Set WshShell=WScript.CreateObject("WScript.Shell")
  File=FSO.GetFile(WScript.ScriptFullName)
  Folder=FSO.GetParentFolderName(File)
  N=Now
  Path=Folder & "\" & T & " " & ValidName(FileDateTime(N),".txt")
  Set File=FSO.CreateTextFile(Path,True,True)		' Overwrite existing, use Unicode
  File.WriteLine "<#>iTunes Metadata - Exported " & FormatDateTime(Now())
  Open=True
End Sub


' Path below media folder, e.g. <AlbumArtist>\<Album>\## <Name>.<Ext>, optonally ignore extension
' Modified 2020-12-21
Function PartPath(P)
  Dim I
  I=InStrRev(P,"\")
  If I>0 Then I=InStrRev(P,"\",I-1)
  If I>0 Then I=InStrRev(P,"\",I-1)
  If I>0 Then PartPath=Mid(P,I+1) Else PartPath=P
  If IgnoreExt Then I=InStrRev(PartPath,".") : PartPath=Left(PartPath,I-1)
End Function


' Custom prompt for track-by-track confirmation
' Modified 2012-12-18
Function Prompt(T)
  Dim AA,AL,DC,DN,TN,P
  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
    P="Export metadata for:" & nl & AA & " - " & AL & nl
    If TN>0 Then
      If DN>1 Or (DN>0 And DC>1) Then P=P & DN & "-"
      P=P & TN & " "
    End If
    P=P & .Name & "?" & nl
    P=P & nl & "Genre" & Tab & .Genre
    P=P & nl & "Plays" & Tab & .PlayedCount
    P=P & nl & "Skips" & Tab & .SkippedCount
  End With
  Prompt=P
End Function


' Save album art in an Artwork folder where the script is in the form <Artist> - <Album>.jpg
' Modified 2020-09-16
Function SaveArt(T)
  Dim AA,AL,Art,File,Folder,Img,R,Update
  File=""
  With T
    If .Location<>"" Then       ' Cannot save art from a file that cannot be found
      AA=.AlbumArtist & "" : If AA="" Then AA=.Artist & "" : If AA="" Then AA="Unknown Artist"
      AL=.Album & "" : If AL="" Then AL="Unknown Album"
      Set Art=.Artwork
      If Art.Count>0 Then	      ' Found some art, try to save
        Update=True
        Folder=FSO.GetParentFolderName(Path) & "\Artwork"
        If FSO.FolderExists(Folder)=False Then FSO.CreateFolder(Folder)
        File=Folder & "\" & ValidName(AA & " - " & AL,".jpg")
        If FSO.FileExists(File) Then
          Update=FSO.GetFile(File).DateLastModified<.ModificationDate
        End If
        If Update Then          ' Update existing image if potentially newer
          Set Img=Art.Item(1)
          On Error Resume Next  ' Catch any error saving the file
          Img.SaveArtworkToFile(File)
          If Err.Number<>0 Then
            On Error Goto 0
            R=MsgBox("Error Message: &" & Hex(Err.Number) & " " & Err.Description & nl & "while saving image to:" & nl & File,vbExclamation+vbOKCancel,Title)
            If R=vbCancel Then wscript.quit
            File=""             ' Failed to save, don't export file path
          End If
          On Error Goto 0
        End If
      End If
    End If
  End With
  SaveArt=File
End Function


' Create a signature to identify a file from tag properties, updated for alternate key
' Modified 2021-01-07
Function Signature(T)
  With T
    If AltKey Then              ' Adjust signtaure to something that can be identified in the library and compared to an exported property
      'Signature=LCase(GroupDig(.Size) & " bytes")
      'Signature=LCase(.Size & "")
      'Signature=.Location
      Signature=LCase(PartPath(.Location))
    Else
      Signature=PersistentID(T)      
    End If
  End With
End Function


' Obtain sort value, return blank if sort value is the same as main value after removing leading article
' Return iTunes like sort name
' Modified 2014-09-17
Function SortValue(M,S)
  Dim L,N
  N=LTrim(M)
  L=LCase(N)
  If Left(L,2)="a " Then
    N=Mid(N,3)
  ElseIf Left(L,3)="an " Then 
    N=Mid(N,4)
  ElseIf Left(L,3)="""a " Then 
    N=Mid(N,4)
  ElseIf Left(L,4)="the " Then 
    N=Mid(N,5)
  ElseIf Left(L,4)="""an " Then 
    N=Mid(N,5)
  ElseIf Left(L,5)="""the " Then 
    N=Mid(N,6)
  End If
  If N=S Then SortValue="" Else SortValue=S
End Function


' Export result (based on standard report sub)
' Modified 2021-01-01
Sub Result
  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 record" & Plural(P,"s","")
  If P<Count Then T=T & " of " & GroupDig(Count)
  T=T & Plural(P," were"," was") & " processed from 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," properties were"," property was") & " exported")
  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
  If U>0 Then T=T & nl & nl & "The exported data was saved as:" & nl & Wrap(Path,60,"\",0)
  T=T & nl & nl & "If required edit the file and/or change libraries " & nl & "then drag & drop onto this script to import."
  MsgBox T,vbInformation,Title
End Sub


' Import result (based on standard report sub)
' Modified 2020-09-06
Sub Rundown
  If Not Outro Then Exit Sub
  Dim L,T
  L=""
  If Quit Then T="Script aborted!" & nl & nl Else T=""
  T=T & "Metadata for " & GroupDig(P) & " track" & Plural(P,"s","")
  ' If P<LC Then T=T & " of " & GroupDig(LC)
  T=T & " was processed for which " & nl
  'If D>0 Then L=PrettyList(L,GroupDig(D) & Plural(D," were duplicates"," was a duplicate") & " in the list")
  L=PrettyList(L,GroupDig(U+V) & Plural(U+V," properties were"," property was") & " reviewed")
  If U>0 Then
    L=PrettyList(L,GroupDig(U) & Plural(U," properties were"," property was") & " updated")
    If V>0 Then L=PrettyList(L,GroupDig(V) & Plural(V," properties were"," property was") & " unchanged")
  Else
    L=PrettyList(L,"none were updated")
  End If
  '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," records were"," record was") & " not matched")
  If ML>0 Then L=PrettyList(L,GroupDig(ML) & Plural(ML," files were"," file 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
  If CheckTime Then T=T & nl & nl & "The system clock has been modified, check the time!"
  MsgBox T,vbInformation,Title
End Sub


' Custom status message for progress bar
' Modified 2014-09-26
Function Status(N)
  Status="Processing " & GroupDig(N) & " of " & GroupDig(Count)
End Function


' Custom trace messages for troubleshooting, T is the current track if needed 
' Modified 2021-01-07
Sub Trace(T,M)
  If Tracing Then
    Dim R,Q
    If IsNull(T) Then Q="" Else Q=Info(T)
    If Q<>"" Then Q=Q & nl & nl 
    Q=Q & M & nl & nl
    Q=Q & "Yes" & tab & tab & "Continue tracing" & nl
    Q=Q & "No" & tab & tab & "Skip further tracing" & nl
    Q=Q & "Cancel" & tab & tab & "Abort script"
    R=MsgBox(Q,vbYesNoCancel,Title & " (" & GroupDig(P) & "/" & GroupDig(Count) &")")
    If R=vbCancel Then WScript.Quit
    If R=vbNo Then
      Tracing=False
    End If
  End If
End Sub


' Test for tracks which can be usefully updated
' Modified 2012-12-18
Function Updateable(T)
  Dim ID
  ID=PersistentID(T)
  Updateable=False              ' Default position
  If IDs.Exists(ID) Then        ' Ignore tracks already processed
    D=D+1                       ' Increment duplicate tracks
  Else
    IDs.Add ID,0                ' Note ID to prevent reprocessing this track
    Updateable=True             ' Always attempt to process unique items        
  End If
End Function


' Convert date & time to UTC string
' Modified 2020-10-13
' Adapted from https://devblogs.microsoft.com/scripting/hey-scripting-guy-how-can-i-set-the-date-and-time-on-a-computer/
Function UTC(T)
  Dim objSWbemDateTime
  Set objSWbemDateTime = CreateObject("WbemScripting.SWbemDateTime")
  objSWbemDateTime.SetVarDate T, True
  UTC=objSWbemDateTime.Value
End Function


' Set current date & time to UTC string
' Modified 2020-10-13
' Adapted from https://devblogs.microsoft.com/scripting/hey-scripting-guy-how-can-i-set-the-date-and-time-on-a-computer/
Sub SetUTC(U)
  Dim colOSes,objOS,objWMIService,strComputer
  strComputer="."
  Set objWMIService = GetObject("winmgmts:{(Systemtime)}\\" & strComputer & "\root\cimv2")
  Set colOSes = objWMIService.ExecQuery("Select * From Win32_OperatingSystem")
  For Each objOS In colOSes
    objOS.SetDateTime U
  Next
End Sub


' 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


' WriteLine to text file
' Modified 2014-09-27
Sub WriteLine(T)
  File.WriteLine T
  U=U+1
End Sub




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


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


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


' Initialise track selections, quit script if track selection is out of bounds or user aborts
' Modified 2019-12-17
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
  'The following line commeneted out to allow this script to work with content on a connected device
  '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 function" & nl
      Q=Q & "or change the declaration ''Prog=True'' to ''Prog=False'' to hide this message. "
      Prog=False
    End If
    If Check Then
      R=MsgBox(Q,vbYesNoCancel+vbQuestion,Title)
    Else
      R=MsgBox(Q,vbOKCancel+vbQuestion,Title)
    End If
    If R=vbCancel Then WScript.Quit
    If R=vbYes or R=vbOK Then
      Check=False
    Else
      Check=True
    End If
  End If 
  If Check Then Prog=False      ' Suppress progress bar if prompting for user input
End Sub


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


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


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


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


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


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


' Loop through track selection processing suitable items
' Modified 2019-12-17
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)
    'The following line commeneted out to allow this script to work with content on a connected device
    'Set T=PersistentObject(T)   ' Attach to object in library playlist
    If Prog Then PB.SetInfo Info(T)
    If T.Kind=1 Then            ' Ignore tracks which can't change
      If Updateable(T) Then     ' Ignore tracks which won't change
        If Check Then           ' Track by track confirmation
          Q=Prompt(T)
          StopTimer             ' Don't time user inputs 
          R=MsgBox(Q,vbYesNoCancel+vbQuestion,Title & " - " & GroupDig(N) & " of " & GroupDig(Count))
          StartTimer
          Select Case R
          Case vbYes
            C=True
          Case vbNo
            C=False
            S=S+1               ' Increment skipped tracks
          Case Else
            Quit=True
            Exit For
          End Select          
        Else
          C=True
        End If
        If C Then               ' We have a valid track, now do something with it
          Action T
        End If
      End If
    End If 
    P=P+1                       ' Increment processed tracks
    If Quit Then Exit For       ' Abort loop on user request
  Next
  StopTimer
  If Prog And Not Quit Then
    PB.Progress Count,Count
    WScript.Sleep 250
  End If
  If Prog Then PB.Close
End Sub


' Output report
' Modified 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 after character C working back from up to W characters adding T tabs to each new line
' Modified 2014-09-27
Function Wrap(S,W,C,T)
  Dim P
  If Len(S)<=W Then
    Wrap=S
  Else    
    P=InstrRev(S,C,W)
    If P Then Wrap=Left(S,P) & nl & String(T,tab) & Wrap(Mid(S,P+1),W,C,T)
  End If
End Function


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

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

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

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

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

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

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

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

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

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


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


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