' ===============
' PlaylistsToFile
' ===============
' Version 1.0.0.6 - March 25th 2021
' Copyright © Steve MacGuire 2011-2021
' http://samsoft.org.uk/iTunes/PlaylistsToFile.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
' ===========
' Write out playlist names to a file

' =========
' ChangeLog
' =========
' Version 1.0.0.1 - Initial version
' Version 1.0.0.2 - Add track counts
' Version 1.0.0.3 - Ignore possible error in Parents function - See https://discussions.apple.com/message/20806337#20806337
' Version 1.0.0.4 - Fix error while displaying results
' Version 1.0.0.5 - Tweak text output after listing a folder and final summary
' Version 1.0.0.6 - Correct bug when XML isn't generated, output to same folder as script, made track counts and lines optional


' Visit http://samsoft.org.uk/iTunes/scripts.asp for updates

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

' =============================
' Declare constants & variables
' =============================
Option Explicit	        ' Declare all variables before use
Dim Intro,Outro,Check   ' Manage confirmation dialogs
Dim iTunes              ' Handle to iTunes application
Dim FSO                 ' Handle to File System Object
Dim WshShell            ' Handle to Shell
Dim P,S,U               ' Counters
Dim nl,tab              ' New line/tab strings
Dim Path                ' Path for output file
Dim Counts,Lines        ' Display options

Const Title="Playlists To File"
Const Summary="Write out playlist names to:"

' =======================
' Initialise user options
' =======================
Intro=True              ' Set false to skip initial prompts, avoid if non-reversible actions
Outro=True              ' Produce summary report
Check=False             ' Step-by-step confirmation
Counts=True             ' Display song counts
Lines=True              ' Display guide lines to counts

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

Init                    ' Set things up
ProcessLists            ' Main process 
Report                  ' Summary

' ===================
' End of main program
' ===================


' ===============================
' Declare subroutines & functions
' ===============================


' Initialisation routine
' Modified 2021-03-25
Sub Init
  Dim File,Folder,N,Q,R
  ' Initialise global variables
  P=0
  S=0
  U=0
  nl=vbCrLf
  tab=Chr(9)
  ' Initialise global objects
  Set iTunes=CreateObject("iTunes.Application")
  Set FSO=CreateObject("Scripting.FileSystemObject")
  Set WshShell=WScript.CreateObject("WScript.Shell")
  File=FSO.GetFile(WScript.ScriptFullName)
  Folder=FSO.GetParentFolderName(File)
  N=Now
  Path=Folder & "\Playlists " & ValidName(FileDateTime(N),".txt")
  'Path=iTunes.LibraryXMLPath
  'S=InstrRev(Path,"\")
  'Path=Left(Path,S) & "Playlists.txt" 
  If Intro Then
    Q=Summary & nl & nl & Path & nl & nl & "Proceed?"
    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 

End Sub


' 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


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



' Loop through playlists
' Modified 2013-01-05
Sub ProcessLists
  Dim C,LC,F,File,Gap,I,Indent,L,Length,Lists,M,T
  Gap=" "       ' Gap between text and line
  Indent=2      ' Indent for folders
  Length=80     ' Overall line length
  F=0
  LC=0
  Set File=FSO.CreateTextFile(Path, True)
  Set Lists=iTunes.Sources.Item(1).Playlists
  With File
    .WriteLine "iTunes playlists - " & FormatDateTime(Now())
    .WriteLine ""
    For I=1 To Lists.Count
      Set L=Lists.Item(I)
      If L.Kind=2 Then
        C=Parents(L)
        If L.SpecialKind=4 Then
          ' Style for folders
          F=F+1
          .WriteLine ""
          T=Right("       " & "(" & FormatNumber(L.Tracks.Count,0,,,-1),8) & ")"
          .Write String(C*Indent," ") & L.Name
          If Counts Then .Write Gap & String(Length-C*Indent-Len(L.Name)-Len(T)-Len(Gap)*2," ") & Gap & T
          .WriteLine ""       
        Else
          ' Style for other playlists
          If LC>C Then .WriteLine ""
          T=" " & Right("       " & FormatNumber(L.Tracks.Count,0,,,-1),8) & " "
          .Write String(C*Indent," ") & L.Name
          If Counts Then
            If Lines Then
              .Write Gap & String(Length-C*Indent-Len(L.Name)-Len(T)-Len(Gap)*2,"_") & Gap & T
            Else
              .Write Gap & String(Length-C*Indent-Len(L.Name)-Len(T)-Len(Gap)*2," ") & Gap & T
            End If
          End If
          .WriteLine ""
        End If
        LC=C
        U=U+1
      End If
      P=P+1
    Next
    .WriteLine ""
    If F>0 Then
      .WriteLine "There are " & U-F & " playlists and " & F & " playlist folder" & Plural(F,"s.",".")
    Else
      .WriteLine "There are " & U-F & "playlists."
    End If
  End With
End Sub


' Count parents of playlist
' Modified 2013-01-05
Function Parents(L)
  Dim P
  Parents=0
  Set P=L.Parent
  ' Ignore possible error - See https://discussions.apple.com/message/20806337#20806337
  On Error Resume Next
  If Not (P Is Nothing) Then Parents=Parents(P)+1
End Function


' Output report
' Modified 2013-01-05
Sub Report
  If Not Outro Then Exit Sub
  WshShell.Run """" & Path & """"
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


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