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