' ============== ' EmbediTunesArt ' ============== ' Version 1.0.0.1 - September 18th 2020 ' Copyright © Steve MacGuire 2010-2020 ' http://samsoft.org.uk/iTunes/EmbediTunesArt.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 ' =========== ' Creates a cache of iTunes downloaded or embedded artwork, then embeds art into any track that doesn't have embedded art ' Related scripts: CleanDeadArt, CreateFolderArt, EmbedFolderArt, EmbediTunesArt ' ========= ' ChangeLog ' ========= ' Version 1.0.0.1 - Initial version ' ========== ' To-do List ' ========== ' Add 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=1 ' 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 ' Additional variables for this particular script ' Modified 2020-09-18 Dim FSO ' Handle to FileSystemObject Dim N ' Timestamp ' ======================= ' Initialise user options ' ======================= ' Custom values for this script ' Modified 2020-09-18 Intro=True ' Set false to skip initial prompts, avoid if non-reversible actions Outro=True ' Produce summary report Check=False ' Track-by-track confirmation Prog=False ' 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=False ' Display/suppress tracing messages Title="Embed iTunes Art" Summary="Creates a cache of iTunes downloaded or embedded artwork, then embeds art into any track that doesn't have embedded art" ' ============ ' Main program ' ============ Init ' Set things up ProcessTracks ' Main process Report ' Summary ' =================== ' End of main program ' =================== ' =============================== ' Declare subroutines & functions ' =============================== ' 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 ' Get album art from Artwork folder where the script is in the form - .jpg ' Modified 2020-09-18 Function GetArt(T) Dim AA,AL,Art,File,Folder,Img,R,Update File="" With T AA=.AlbumArtist & "" : If AA="" Then AA=.Artist & "" : If AA="" Then AA="Unknown Artist" AL=.Album & "" : If AL="" Then AL=.Name : If AL="" Then AL="Unknown Album" Folder=FSO.GetParentFolderName(WScript.ScriptFullName) & "\Artwork" File=Folder & "\" & ValidName(AA & " - " & AL,".jpg") If FSO.FileExists(File) Then ' Found an image, now embed it if necessary If .Artwork.Count=1 Then ' Erase any downloaded artwork If .Artwork.Item(1).IsDownloadedArtwork Then .Artwork.Item(1).Delete ' Then remove the store art End If End If If .Artwork.Count=0 Then ' Now art if a track doesn't have art .AddArtworkFromFile(File) ' Should probably add an error handler here U=U+1 ' Increment update counter Else V=V+1 ' Increment counter of unchanged tracks End If End If End With End Function ' Group digits and separate with commas ' Modified 2014-04-29 Function GroupDig(N) GroupDig=FormatNumber(N,0,-1,0,-1) End Function ' Initialise track selections, quit script if track selection is out of bounds or user aborts ' Modified 2020-09-18 Sub Init Dim R,T ' Initialise global variables D=0 M=0 P=0 S=0 U=0 V=0 Quit=False nl=vbCr & vbLf ' Initialise global objects Set FSO=CreateObject("Scripting.FileSystemObject") Set iTunes=CreateObject("iTunes.Application") ' Set SH=CreateObject("Shell.Application") Set Tracks=iTunes.SelectedTracks ' Will error if open modal dialog box If Tracks is Nothing Then If iTunes.BrowserWindow.SelectedPlaylist.Source.Name<>"Library" Then Set Tracks=iTunes.LibraryPlaylist.Tracks Else Set Tracks=iTunes.BrowserWindow.SelectedPlaylist.Tracks End If End If Count=Tracks.Count ' Check there is a suitable number of suitable tracks to work with IF CountMax 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 If Intro Then T=Summary & nl & nl & "Process " & GroupDig(Count) & " track" & Plural(Count,"s","") & "?" R=MsgBox(T,vbOKCancel+vbQuestion,Title) If R=vbCancel Then WScript.Quit End If End Sub ' 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 ' Modified 2012-08-25 Function PrettyList(L,N) If L="" Then PrettyList=N & "." Else 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 2020-09-18 Sub ProcessTracks Dim I,T,SA StartTimer For I=1 To Count ' First pass, cache any new artwork images Set T=Tracks.Item(I) If T.Kind=1 Then ' Only process "File" tracks P=P+1 SaveArt T End If Next For I=1 To Count ' Second pass to insert fresh art in tracks that need it Set T=Tracks.Item(I) If T.Kind=1 Then ' Only process "File" tracks If T.Location<>"" Then ' Cannot embed art in missing tracks GetArt T Else M=M+1 ' Increment mIssing tracks End If End If Next StopTimer End Sub ' Output report ' Modified 2020-09-18 Sub Report If Not Outro Then Exit Sub Dim L,T T=GroupDig(P) & " track" & Plural(P,"s","") If P0 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 M>0 Then L=PrettyList(L,GroupDig(M) & Plural(M," were"," was") & " missing") L=L & nl & GroupDig(S) & " new image" & Plural(S,"s were"," was") & " saved." T=T & L If Timing Then T=T & nl & nl & "Running time: " & FormatTime(Clock) & "." End If MsgBox T,vbInformation,Title End Sub ' Save album art in an Artwork folder where the script is in the form - .jpg ' Modified 2020-09-18 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=.Name : 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(WScript.ScriptFullName) & "\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 ' MsgBox "File date = " & FSO.GetFile(File).DateLastModified & nl & "Track date = " & .ModificationDate & nl & "Update = " & Update 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 Else S=S+1 ' Update saved art counter End If On Error Goto 0 End If End If End If End With SaveArt=File End Function ' Start timing session ' Modified 2011-10-08 Sub StartTimer T1=Timer 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 ' 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 ' ==============