' =============== ' iTunesAlbumList ' =============== ' Version 1.0.0.1 - October 14th 2020 ' Copyright © Steve MacGuire 2011-2020 ' http://samsoft.org.uk/iTunes/iTunesAlbumList.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 album to a file ' Written in response to https://discussions.apple.com/thread/251913090 ' ========= ' ChangeLog ' ========= ' Version 1.0.0.1 - Initial version ' 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 File ' The output file Dim Length ' Length of separator line Dim RunTime ' Script run time Const Title="iTunes Album List" Const Summary="Write out album list to:" ' ======================= ' Initialise user options ' ======================= Intro=True ' Set false to skip initial prompts, avoid if non-reversible actions Outro=True ' Produce summary report Length=120 ' Length of separator line ' ============ ' Main program ' ============ Init ' Set things up ProcessLibrary ' Main process Report ' Summary ' =================== ' End of main program ' =================== ' =============================== ' Declare subroutines & functions ' =============================== ' Return Album, coping with empty values or cloud errors ' Modified 2020-10-14 Function Album(T) On Error Resume Next Album="" If T.Album & ""<>"" Then Album=T.Album If Album="" Then Album="Unknown Album" End Function ' Return AlbumArtist, coping with empty values or cloud errors ' Modified 2020-10-14 Function AlbumArtist(T) AlbumArtist="" If T.Compilation Then AlbumArtist="Compilations" On Error Resume Next If AlbumArtist="" Then If T.AlbumArtist & ""<>"" Then AlbumArtist=T.AlbumArtist On Error Goto 0 If AlbumArtist="" Then If T.Artist & ""<>"" Then AlbumArtist=T.Artist If AlbumArtist="" Then AlbumArtist="Unknown Artist" 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 ' Group digits and separate with commas ' Modified 2014-04-29 Function GroupDig(N) GroupDig=FormatNumber(N,0,-1,0,-1) End Function ' Initialisation routine ' Modified 2020-10-14 Sub Init Dim 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") RunTime=Now Path=MyFolder & "\" & Title & " " & ValidName(FileDateTime(RunTime),".txt") If Intro Then Q=Summary & nl & Path & nl & nl & "Proceed?" R=MsgBox(Q,vbOKCancel+vbQuestion,Title) If R=vbCancel Then WScript.Quit End If End Sub ' Get folder ths script is running from ' Modified 2020-10-14 Function MyFolder Dim File Set FSO=CreateObject("Scripting.FileSystemObject") Set WshShell=WScript.CreateObject("WScript.Shell") File=FSO.GetFile(WScript.ScriptFullName) MyFolder=FSO.GetParentFolderName(File) End Function ' Create a text file for output ' Modified 2020-10-14 Sub OutputFile Set File=FSO.CreateTextFile(Path,True,True) ' Overwrite existing, use Unicode File.WriteLine "iTunes Album List - Exported " & FormatDateTime(RunTime) File.WriteLine String(Length,"_") File.WriteLine "" End Sub ' 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 2020-10-14 Sub ProcessLibrary Dim AL,Albums,AR,Array,C,I,Item,J,Key,L,Lists,SAL,SAR,Swap,T,Temp,Tracks C=0 Set Albums=CreateObject("Scripting.Dictionary") ' MsgBox "Expand this sub",0,Title ' Set Tracks=iTunes.LibraryPlaylist.Tracks Set Lists=iTunes.LibrarySource.Playlists For Each L in Lists If L.Name="Music" Then ' Locate Music source Set Tracks=L.Tracks For Each T In Tracks AL=Album(T) AR=AlbumArtist(T) SAL=SortAlbum(T) SAR=SortAlbumArtist(T) Key=SAR & " | " & SAL If Not Albums.Exists(Key) Then ' Add unique artist - album combos Albums.Add Key, AR & " | " & AL End If Next Exit For End If Next C=Albums.Count ReDim Array(C) ' Copy dictionary into an array I=0 For Each Item in Albums.Keys Array(I)=Item I=I+1 Next If C>1 Then ' BubbleSort the array into ascending order Do Swap=False For I=1 To C-1 If LCase(Array(I))"" Then SortAlbum=T.SortAlbum On Error Goto 0 If SortAlbum="" And T.Album & ""<>"" Then SortAlbum=SortName(T.Album) If SortAlbum="" Then SortAlbum="Unknown Album" End Function ' Return SortAlbumArtist, coping with empty values or cloud errors ' Modified 2020-10-14 Function SortAlbumArtist(T) On Error Resume Next SortAlbumArtist="" If T.Compilation Then SortAlbumArtist="~~~ Compilations" ' Sort last If SortAlbumArtist="" Then If T.SortAlbumArtist & ""<>"" Then SortAlbumArtist=T.SortAlbumArtist If SortAlbumArtist="" Then If T.AlbumArtist & ""<>"" Then SortAlbumArtist=SortName(T.AlbumArtist) If SortAlbumArtist="" Then If T.SortArtist & ""<>"" Then SortAlbumArtist=T.SortArtist On Error Goto 0 If SortAlbumArtist="" Then If T.Artist & ""<>"" Then SortAlbumArtist=SortName(T.Artist) If SortAlbumArtist="" Then SortAlbumArtist="Unknown Artist" End Function ' Return iTunes like sort name ' Modified 2020-10-14 Function SortName(N) Dim L N=LTrim(N) If Left(N,1)="'" Then N=Mid(N,2) If Left(N,1)="""" Then N=Mid(N,2) 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,4)="the " Then SortName=Mid(N,5) 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 ' ============== ' End of listing ' ==============