' ===============
' 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))<LCase(Array(I-1)) Then
          Temp=Array(I)
          Array(I)=Array(I-1)
          Array(I-1)=Temp
          Swap=True
        End If
      Next
    Loop While Swap
  End If
  'MsgBox "Albums = " & nl & Albums.Item(Array(0)) & nl & Albums.Item(Array(1)) & nl & Albums.Item(Array(2)) & nl & Albums.Item(Array(3)) & nl & Albums.Item(Array(4)) & nl & "etc.",0,Title
  OutputFile                            ' Create the output file
  For I=0 To C-1
      File.WriteLine Albums.Item(Array(I))
  Next
  File.WriteLine String(Length,"_")
  File.WriteLine ""
  File.WriteLine "There were " & GroupDig(C) & " albums in the library."
  File.Close
End Sub


' Output report
' Modified 2013-01-05
Sub Report
  If Not Outro Then Exit Sub
  WshShell.Run """" & Path & """"
End Sub


' Return SortAlbum, coping with empty values or cloud errors
' Modified 2020-10-14
Function SortAlbum(T)
  On Error Resume Next
  SortAlbum=""
  If T.SortAlbum & ""<>"" 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
' ==============