' =============
' ImportFromXML
' =============
' Version 1.0.0.6 - January 24th 2021
' Copyright © Steve MacGuire 2011-2021
' http://samsoft.org.uk/iTunes/ImportXML.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
' ===========
' Attempts to import play counts from XML playlist, currently linking items using an alternate key based on partial file path
' E.g. <AlbumArtist>\<Album>\## <Name>.<Ext>

' Related scripts: ExportImport, ExportImportAltKey, ExportImportPlays, ExportImportRatings, ImportFromXML



' =========
' ChangeLog
' =========
' Version 1.0.0.1 - Initial version - Adapted from ExportImport V. 1.0.0.24
' Version 1.0.0.2 - Stop processing XML at <key>Playlists</key>, add import of skip count and play/skip dates, fix time zone offset weirdness,
'                   correct for XML locaton file:/// vs. file://localhost/, options to ignore file ext. and unmatched records with zero play counts
' Version 1.0.0.3 - Minor update to dialog boxes
' Version 1.0.0.4 - Fix bug with skip data vs. play data, add logging output listing failed imports 
' Version 1.0.0.5 - Add location for failed imports, should match those iTunes failed to import from the XML
' Version 1.0.0.6 - Adjust search path to account for iTunes 40 character file/folder name limit


' ==========
' 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-12-17
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="Import From XML"
Summary="Import play counts from XML playlist" & vbCrLf & vbCrLf

' Additional variables for this particular script
' Modified 2021-01-07
Dim AddToOldPlays,AltKey,Artwork,CheckTime,IgnoreExt,IgnoreZeros,K,KD,Keys,KT,LC
Dim File,Force,FSO,Path,Open,OpenExport,WshShell,nlRep,Mode,TZOffset
Dim Limit,Log,Logging,LogOpen,LogPath,OpenLog

' 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=True             ' Use where PersistentID won't be the same
IgnoreExt=True          ' Optonally ignore extention for alternate key
IgnoreZeros=False       ' Suppress reporting of unmatched record if play count is zero
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
Logging=True            ' Enable logging
LogOpen=False           ' Flag for logging
OpenLog=True            ' Open any log file after import
Limit=True              ' Use limited file/folder length


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

If WScript.Arguments.Count<>1 Then
  MsgBox "Drag a single .xml file onto this script to import metadata.",vbCritical,Title
  WScript.Quit
ElseIf WScript.Arguments.Count=1 Then
  Path=WScript.Arguments.Item(0)
  If LCase(Right(Path,4))<>".xml" Then
    MsgBox "Drag a single .xml file onto this script to import metadata.",vbCritical,Title
    WScript.Quit
  End If
  Mode="Import"
  ImportFile
Else                    ' Unused legacy code from source script ExportImport
  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 - Unused legacy code from source script
' 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


' Date as string or custom value when zero
' Modified 2020-12-21
Function DateVal(D)
  If D=0 Then DateVal="<Never>" & tab Else DateVal=D
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 2020-12-21
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=" & Key & nl & "Value=" & 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-24
Sub ImportFile
  Dim Art,B,Base,C,Ext,F,I,Key,L,Line,Loc,Mode,N,NewFile,Offset,PC,PD,PID,Playlists,Q,R,SC,SD,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
  ' Initialise global objects
  Set iTunes=CreateObject("iTunes.Application")
  Set FSO=CreateObject("Scripting.FileSystemObject")
  C=0 : I=0 : LC=0 : N=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,-2)	' Read only, don't create, system default
  Do 
    Line=File.ReadLine
    If Instr(Line,"<key>Location</key>") Then
      C=C+1
    End If
    LC=LC+1
  Loop Until File.AtEndOfStream Or Instr(Line,"<key>Playlists</key>")
  File.Close
  
  ' MsgBox "There are " & LC & " lines in the XML with properties for " & C & " tracks.",0,Title 
  Count=C
  
  ' Confirmation dialogs
  If C=0 Then
    Q="The file " & F & " contains no valid entries!"
    MsgBox Q,vbCritical,Title
    WScript.Quit
  End If
  If Intro Or (Prog And UAC) Then
    Q="Import metadata for " & GroupDig(C) & " item" & Plural(C,"s","") & "?"
    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
  ElseIf Prog And UAC Then
    Prog=False
  End If
  If Check Then Prog=False      ' Suppress progress bar if prompting for user input
  
  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
  PC=0 : PD=0 : SC=0 : SD=0     ' Zero play/skip counts/dates in case omitted in first XML record
  Set File=FSO.OpenTextFile(Path,1,False,-2)	          ' Read only, don't create, system default
  Do
    Line=File.ReadLine
    If Instr(Line,"<key>Play Count</key>") Then         ' Found play count property, save until next location
      PC=XmlPlayCount(Line)
    End If
     If Instr(Line,"<key>Play Date UTC</key>") Then     ' Found play date property, save until next location
      PD=XmlPlayDate(Line)
    End If
    If Instr(Line,"<key>Skip Count</key>") Then         ' Found skip count property, save until next location
      SC=XmlSkipCount(Line)
    End If
    If Instr(Line,"<key>Skip Date</key>") Then          ' Found skip date property, save until next location
      SD=XmlSkipDate(Line)
    End If
    If Instr(Line,"<key>Persistent ID</key>") Then      ' Found persistent ID property, save until next location
      PID=XmlPersistentID(Line)
    End If
    If Instr(Line,"<key>Location</key>") Then           ' Found location property, assign saved play count & date
      N=N+1                                             ' Increment records processed
      Loc=XmlLocation(Line)                             ' Get path
      Key=PartPath(Loc)                                 ' Key with case, easier for human reading
      Line=LCase(Key)
      If Limit Then Line=Truncate(Line)                 ' Limit file and folder names to 40 characters to match iTunes for Windows naming convention
      Set T=Nothing
      If Keys.Exists(Line) Then 
        If Keys.Item(Line)<>"" Then Set T=ObjectFromID(Keys.Item(Line))
      End If
      If T is Nothing Then      ' No matching alternate key found
        If Not (IgnoreZeros And PC=0) Then 
          Trace Null,"There were no matches in the current selection for the item with alternate key " & nl & nl & Key & nl & nl & _
          "which should have its play count updated to " & PC & "." & nl & nl & "Try again without an initial selection, or selecting " & _
          "items more likely to match those from which data was exported, or edit metadata or the XML to recreate matches."
          If Logging Then
            If Not LogOpen Then OutputLog("ImportFromXML")
            Log.WriteLine "<ID>" & PID
            Log.WriteLine "<AltKey>" & Key
            Log.WriteLine "<Location>" & Loc
            If PC>0 Then Log.WriteLine "<Plays>" & PC
            If PD>0 Then Log.WriteLine "<Played>" & PD
            If SC>0 Then Log.WriteLine "<Skips>" & SC
            If SD>0 Then Log.WriteLine "<Skipped>" & SD
            Log.WriteLine ""
          End If
        End If
        M=M+1                   ' Increment missing
      Else
        ' MsgBox Line & nl & "Old Plays=" & T.PlayedCount & nl & "New Plays=" & PC,0,Title
        If T.PlayedCount<>PC Or T.PlayedDate<>PD Or T.SkippedCount<>SC Or T.SkippedDate<>SD Then
          If Check Then         ' Track by track confirmation
            Q=Prompt(T,PC,PD,SC,SD)
            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 : V=V+4     ' Increment skipped records & unchanged properties
            Case Else
              Quit=True
              Exit Do
            End Select          
          Else
            C=True
          End If
          If C Then             ' We have properties to update, make it so and incremend updated
            If T.PlayedCount<>PC Then T.PlayedCount=PC : U=U+1 Else V=V+1
            If DateDiff("s",T.PlayedDate,PD)<>0 Then SetPlayDate T,PD : U=U+1 Else V=V+1
            If T.SkippedCount<>SC Then T.SkippedCount=SC : U=U+1 Else V=V+1
            If DateDiff("s",T.SkippedDate,SD)<>0 Then SetSkipDate T,SD : U=U+1 Else V=V+1
          End If
        Else
          V=V+4                 ' Increment unchanged by 4!
        End If
      End If
      P=P+1                     ' Increment processed records
      PC=0 : PD=0 : SC=0 : SD=0 ' Reset play/skip count/dates in case omitted in next XML record
    End If
    ' Ignore lines from XML other than Play Count and Location
    If Quit Then Exit Do
  Loop Until File.AtEndOfStream Or Instr(Line,"<key>Playlists</key>")
  File.Close
  StopTimer
  If Prog And Not Quit Then
    PB.Progress Count,Count
    WScript.Sleep 250
  End If
  If Prog Then PB.Close
  If LogOpen Then               ' Close log file if open
    Log.Close
    If OpenLog Then WshShell.Run """" & LogPath  & """"
  End If
  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 2020-12-22
Function KeyText(T)
  KeyText=LCase(PartPath(T.Location))
  Exit Function
  
  ' Alternative definition
  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


' Create a text file for logging, with title T & datestamp
' Modified 2021-01-07
Sub OutputLog(T)
  Dim Folder,N,S
  Set FSO=CreateObject("Scripting.FileSystemObject")
  Set WshShell=WScript.CreateObject("WScript.Shell")
  Log=FSO.GetFile(WScript.ScriptFullName)
  Folder=FSO.GetParentFolderName(Log)
  N=Now
  LogPath=Folder & "\" & T & " Log " & ValidName(FileDateTime(N),".txt")
  Set Log=FSO.CreateTextFile(LogPath,True,True)		' Overwrite existing, use Unicode
  Log.WriteLine "<#>ImportFromXML - Error log generated " & FormatDateTime(Now())
  Log.WriteLine "<#>Log format compatible with ExportImportAltKey"
  Log.WriteLine "<#>Could be used to complete metadata import after suitable editing of AltKeys"
  Log.WriteLine ""
  LogOpen=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 2020-12-17
Function Prompt(T,PC,PD,SC,SD)
  Dim AA,AL,DC,DN,TC,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
    TC=.TrackCount
    P="Change details for:" & nl 
    P=P & nl & "Artist" & tab & AA
    P=P & nl & "Album" & tab & AL
    P=P & nl & "Name" & tab & .Name
    If DN>1 Or DC>1 Then P=P & nl & "Disc #" & tab & DN : If DC>0 Then P=P & " of " & DC
    P=P & nl & "Track #" & tab & TN : If TC>0 Then P=P & " of " & TC
    P=P & nl & nl & tab & "From:" & tab & tab & "To:"
    If .PlayedCount<>PC Then P=P & nl & "Plays" & tab & .PlayedCount & tab & tab & PC
    If .PlayedDate<>PD Then P=P & nl & "Play Date" & tab & DateVal(.PlayedDate) & tab & DateVal(PD)
    If .SkippedCount<>SC Then P=P & nl & "Skips" & tab & .SkippedCount & tab & tab & SC
    If .SkippedDate<SD Then P=P & nl & "Skip Date" & tab & DateVal(.SkippedDate) & tab & DateVal(SD)
  End With
  Prompt=P
End Function


' Export result (based on standard report sub)
' Modified 2014-09-27
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-12-17
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 V>0 And U>0 Then L=PrettyList(L,GroupDig(V) & Plural(V," properties were"," property was") & " unchanged")  
  If U>0 Then
    L=PrettyList(L,GroupDig(U) & Plural(U," properties were"," property was") & " updated")
  Else
    L=PrettyList(L,"none were updated")
  End If
  If S>0 Then L=PrettyList(L,GroupDig(S) & Plural(S," updates were"," was") & " skipped")
  
  If M>0 Then L=PrettyList(L,GroupDig(M) & Plural(M," records were"," record was") & " not matched")
  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


' 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


' Set date, correcting for TZOffset weirdness
' Modified 2020-12-21
Sub SetPlayDate(T,D)
  Dim TZO
  T.PlayedDate=D
  If T.PlayedDate<>D Then
    TZO=DateDiff("h",T.PlayedDate,D)
    'MsgBox "Time Zone Offset = " & TZO & " but why?"
    T.PlayedDate=DateAdd("h",TZO,D)     ' Corrects for unwanted TZOffset
  End If
  'If T.PlayedDate<>D Then MsgBox "Fix issue with GetPlayDate" : WScript.Quit
End Sub


' Set date, correcting for TZOffset weirdness
' Modified 2020-12-21
Sub SetSkipDate(T,D)
  Dim TZO
  T.SkippedDate=D
  If T.SkippedDate<>D Then
    TZO=DateDiff("h",T.SkippedDate,D)
    'MsgBox "Time Zone Offset = " & TZO & " but why?"
    T.SkippedDate=DateAdd("h",TZO,D)     ' Corrects for unwanted TZOffset
  End If
  'If T.SkippedDate<>D Then MsgBox "Fix issue with GetSkipDate" : WScript.Quit
End Sub


' 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


' Create a signature to identify a file from tag properties, updated for alternate key
' Modified 2020-12-22
Function Signature(T)
  With T
    If AltKey Then              ' Adjust signature to something that can be identified in the library and compared to an exported property
      'Signature=LCase(GroupDig(.Size) & " bytes")
      'Signature=LCase(.Size & "")
      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


' 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
    StopTimer
    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
    StartTimer
  End If
End Sub


' Truncate file and folder names in path down to 40 characters, eliminating any trailing space and preserving extension
' Modified 2021-01-24
Function Truncate(T)
  Dim Ext,Part,Parts,I
  Parts=Split(T,"\")
  Part=Parts(UBound(Parts))
  I=InStrRev(Part,".")
  If I>0 Then Ext=Mid(Part,I) Else Ext=""
  If IgnoreExt Then
    Parts(UBound(Parts))=Trim(Left(Part,36))
  Else
    Parts(UBound(Parts))=Trim(Left(Part,40-Len(Ext))) & Ext
  End IF
  For I=0 To UBound(Parts)-1
    Parts(I)=Trim(Left(Parts(I),40))
  Next
  Truncate=Join(Parts,"\")
End Function


' 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


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


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


' Extract file path from XML location property, assume valid input
' Modified 2021-01-09
Function XmlLocation(L)
  L=Replace(L,tab,"")                   ' Strip tabs
  L=Replace(L,"/localhost/","/")        ' Remove localhost path
  L=Replace(L,"<key>Location</key><string>file://","")       ' Trim XML
  L=Replace(L,"</string>","")           ' Trim XML
  L=Replace(L,"&#38;","&")              ' Fix for bug with UnEscape of & 
  L=Replace(L,"/","\")                  ' Correct \ direction
  XmlLocation=UnEscape(L)               ' Unicode from escaped ASCII
End Function


' Extract value from XML pPesistent ID, assume valid input
' Modified 2021-01--7
Function XmlPersistentID(L)
  L=Replace(L,tab,"")                   ' Strip tabs
  L=Replace(L,"<key>Persistent ID</key><string>","")
  L=Replace(L,"</string>","")           ' Trim XML
  XmlPersistentID=Left(L,8) & "-" & Right(L,8)
End Function


' Extract value from XML play count property, assume valid input
' Modified 2020-12-16
Function XmlPlayCount(L)
  L=Replace(L,tab,"")                   ' Strip tabs
  L=Replace(L,"<key>Play Count</key><integer>","")
  L=Replace(L,"</integer>","")          ' Trim XML
  XmlPlayCount=Eval(L)                  ' Read value
End Function


' Extract value from XML play date UTC property, assume valid input
' Modified 2020-12-21
Function XmlPlayDate(L)
  L=Replace(L,tab,"")                   ' Strip tabs
  L=Replace(L,"<key>Play Date UTC</key><date>","")
  L=Replace(L,"</date>","")             ' Trim XML
  XMLPlayDate=DateSerial(Mid(L,1,4),Mid(L,6,2),Mid(L,9,2))
  XMLPlayDate=XMLPlayDate+TimeSerial(Mid(L,12,2),Mid(L,15,2),Mid(L,18,2))
  'MsgBox L & " >>> " & XMLPlayDate
End Function


' Extract value from XML skip count property, assume valid input
' Modified 2020-12-21
Function XmlSkipCount(L)
  L=Replace(L,tab,"")                   ' Strip tabs
  L=Replace(L,"<key>Skip Count</key><integer>","")
  L=Replace(L,"</integer>","")          ' Trim XML
  XmlSkipCount=Eval(L)                  ' Read value
End Function


' Extract value from XML skip date property, assume valid input
' Modified 2020-12-21
Function XmlSkipDate(L)
  L=Replace(L,tab,"")                   ' Strip tabs
  L=Replace(L,"<key>Skip Date</key><date>","")
  L=Replace(L,"</date>","")             ' Trim XML
  XMLSkipDate=DateSerial(Mid(L,1,4),Mid(L,6,2),Mid(L,9,2))
  XMLSkipDate=XMLSkipDate+TimeSerial(Mid(L,12,2),Mid(L,15,2),Mid(L,18,2)) 
End Function   


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


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


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


' Initialise track selections, quit script if track selection is out of bounds or user aborts
' Modified 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, Oxford comma version, back to original
' Modified 2021-01-03
Function PrettyList(L,N)
  If L="" Then
    PrettyList=N & "."
  Else
    ' PrettyList=Replace(Left(L,Len(L)-1),", and" & nl,"," & nl) & ", and" & nl & N & "."
    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
' ==============