' ============= ' SortDateAdded ' ============= ' Version 1.0.1.9 - July 16th 2012 ' Copyright © Steve MacGuire 2010-2012 ' http://samsoft.org.uk/iTunes/SortDateAdded.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 ' =========== ' A VBScript to remove and reimport tracks so that Date Added (Descending) order matches natural album order. ' Assumes tracks have sensible path data so that ordering by path equates to correct track order. ' ========= ' ChangeLog ' ========= ' Version 1.0.0.1 - Initial version ' Version 1.0.0.2 - Remove & reimport tracks rather than try to reassign existing library entries ' Version 1.0.0.3 - Prevent two or more tracks having the same DateAdded value (in seconds) ' Version 1.0.0.4 - Preserve volatile iTunes-only metadata, including playlist membership ' Version 1.0.0.5 - If no tracks are pre-selected then process current playlist ' Version 1.0.0.6 - Ignore non-file tracks, fix behaviour with PDF's, preserve more metadata ' Version 1.0.0.7 - Extend to .wav, .aif .ite & .itlp filetypes ' Version 1.0.0.8 - Extend to .mid ' Version 1.0.0.9 - Minor tweak to array declaration and use of With Object Statement (might speed up the script slightly) ' Version 1.0.1.1 - Add flag to control order ' Version 1.0.1.2 - Time zone correction for restored LastPlayed & LastSkipped ' Version 1.0.1.3 - Updated to new common code base ' Version 1.0.1.4 - Add pauses into code between adding a file and updating it to address possible timing issue ' Version 1.0.1.5 - Better test for completion of add file process ' Version 1.0.1.6 - Another approach! Test ability to edit track info. loop and retry until able to update ' Version 1.0.1.7 - Change sorting criteria to make independant of file path ' Version 1.0.1.8 - Fix for problem setting Exclude From Shuffle flag ' Version 1.0.1.9 - Expanded error handling ' ========== ' To-do List ' ========== ' Add things to do... ' ============================= ' Declare constants & variables ' ============================= Option Explicit ' Declare all variables before use Const Kimo=False ' True if script expects "Keep iTunes Media folder organised" to be disabled Const Min=0 ' Minimum number of tracks this script should work with, 0 for current playlist/library Const Max=0 ' Maximum number of tracks this script should work with, 0 for no limit Const Warn=500 ' Warning level, require confirmation for procssing 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 M,P,S,U,V ' Counters Dim nl,tab ' New line/tab strings Dim Quit ' Used to abort script Dim LT ' Last track added time Dim Desc ' Sort order Dim TimeFactor ' No. of hours to add/subtract to/from PlayedDate to correct for time zone Dim Title,Summary ' No prizes for these two ' ======================= ' Initialise user options ' ======================= 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=True ' 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 Source="" ' Named playlist to process, use "Library" for entire library Desc=True ' True=Descending order, False=Ascending Title="Sort Date Added" Summary="Remove and reimport tracks so they are listed correctly when" & vbCrLf _ & "the library is sorted in Date Added " IF Desc Then Summary=Summary & "(descending) order." Else Summary=Summary & "(ascending) order." End If Dim T3,T4 ' Extra timing for mystery delay on closing progress bar ' ============ ' Main program ' ============ GetTracks ' Set things up SortTracks ' Main process Report ' Summary ' =================== ' End of main program ' =================== ' =============================== ' Declare subroutines & functions ' =============================== ' Note: The bulk of the code in this script is concerned with making sure that only suitable tracks are processed by ' the main SortTracks module and supporting numerous options for track selection, confirmation, progress and results. ' Test ability to update track and retry until able or for 10 attempts ' Modified 2012-02-20 Sub Retry(T,PC) Dim R,S R=0 On Error Resume Next Do R=R+1 ' If there has been an error, pause & reset If Err.Number<>0 Then WScript.Sleep 100 : Err.Clear ' Catch potential exception from next statement T.PlayedCount=PC Loop Until Err.Number=0 Or R>9 If Err.Number<>0 Then S="Repeated error &" & Hex(Err.Number) & " while attempting to update track info." & nl & nl S=S & "Giving up after " & R & " attempt" & Plural(R,"s!","!") MsgBox S,0,Title WScript.Quit ' Else ' MsgBox "Property set after " & R & " attempt" & Plural(R,"s.","."),0,Title End If End Sub ' Return SortAlbum, coping with empty values ' Modified 2012-07-14 Function SortAlbum(T) If T.SortAlbum & ""<>"" Then SortAlbum=T.SortAlbum ElseIf T.Album & ""<>"" Then SortAlbum=SortName(T.Album) Else SortAlbum="Unknown Album" End If End Function ' Return SortAlbumArtist, coping with empty values ' Modified 2012-07-14 Function SortAlbumArtist(T) If T.Compilation Then SortAlbumArtist="Compilations" ElseIf T.SortAlbumArtist & ""<>"" Then SortAlbumArtist=T.SortAlbumArtist ElseIf T.AlbumArtist & ""<>"" Then SortAlbumArtist=SortName(T.AlbumArtist) ElseIf T.SortArtist & ""<>"" Then SortAlbumArtist=T.SortArtist ElseIf T.Artist & ""<>"" Then SortAlbumArtist=SortName(T.Artist) Else SortAlbumArtist="Unknown Artist" End If End Function ' Return padded DiscNumber ' Modified 2012-07-14 Function SortDiscNumber(T) SortDiscNumber=Right("0" & T.DiscNumber,2) End Function ' Return iTunes like sort name ' Modified 2011-01-27 Function SortName(N) Dim L N=LTrim(N) 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,3)="""a " Then SortName=Mid(N,4) If Left(L,4)="the " Then SortName=Mid(N,5) If Left(L,4)="""an " Then SortName=Mid(N,5) If Left(L,5)="""the " Then SortName=Mid(N,6) End Function ' Return padded TrackNumber ' Modified 2012-07-14 Function SortTrackNumber(T) SortTrackNumber=Right("00" & T.TrackNumber,3) End Function ' Sort a selection of tracks into date added order ' Modified 2011-10-10 Sub SortTracks Dim A,C,I,J,R,T,Swapped,Track,Temp,Path(),High(),Low() ReDim Path(Count),High(Count),Low(Count) TimeFactor=TZOffset If Prog Then Set PB=New ProgBar If Prog Then PB.Title=Title ' Note start time of operations If Timing Then Clock=0 : StartTimer J=0 ' Read track data If Prog Then PB.SetStatus "Reading paths" If Prog Then PB.Show For I=1 To Count If Prog Then PB.Progress I,Count Set Track=Tracks.Item(I) If Track.Kind=1 Then If Track.Location="" Then M=M+1 ' Increment missing tracks If Prog Then PB.SetDebug "
Missing file!" : WScript.Sleep 500 Else J=J+1 'Path(J)=Track.Location 'Path(J)=LCase(Track.Location) ' Would correct for random casing inconsistency, however next line is better Path(J)=LCase(SortAlbumArtist(Track) & "\" & SortAlbum(Track) & "\" & SortDiscNumber(Track) & "-" & SortTrackNumber(Track) & " " & Track.Name) High(J)=iTunes.ITObjectPersistentIDHigh(Track) Low(J)=iTunes.ITObjectPersistentIDLow(Track) End If End If Next Count=J ' Reset count to number of "real" tracks. ' BubbleSort path & ids arrays into descending or ascending path order If Prog Then PB.SetStatus "Sorting" If Prog Then PB.Reset If Count>1 Then Do Swapped=False For I=1 To Count-1 If Prog Then PB.Step True If (Desc And Path(I)Path(I+1)) Then Temp=Path(I) Path(I)=Path(I+1) Path(I+1)=Temp Temp=High(I) High(I)=High(I+1) High(I+1)=Temp Temp=Low(I) Low(I)=Low(I+1) Low(I+1)=Temp Swapped=True End If Next Loop While Swapped End If ' Note current time LT=INT(Timer) ' Remove and reimport tracks in path order If Prog Then PB.Reset For I=1 To Count If Quit Then Exit For Set Track=iTunes.LibraryPlaylist.Tracks.ItemByPersistentID(High(I),Low(I)) If Prog Then PB.SetStatus "Processing " & I & " of " & Count If Prog Then PB.Progress I-1+.25,Count If Check Then ' Track by track confirmation With Track T="Update?" & nl & nl & "Artist" & tab & ": " &.Artist & nl & "Album" & tab & ": " &.Album & nl _ & "Name" & tab & ": " &.Name & nl & "Track #" & tab & ": " &.TrackNumber End With StopTimer ' Don't time user inputs R=MsgBox(T,vbYesNoCancel+vbQuestion,Title) StartTimer Select Case R Case vbYes C=True Case vbNo C=False S=S+1 ' User skipped this track Case Else Quit=True Exit For End Select Else C=True End If If C Then ' We have a valid track, now do something with it UpdateTrack High(I),Low(I),I-1 End If If Prog Then PB.Progress I,Count P=P+1 ' Increment processed tracks Next If Timing Then StopTimer If Prog Then WScript.Sleep 500 : PB.Close T3=Timer End Sub ' Remove, then reimport track and restore all metadata not stored in the tag ' Modified 2012-07-14 Sub UpdateTrack(H,L,N) Dim D,I,Path,Playlists,Track,Status,Ext,R,S,Z Dim AA,AL,AR,ARK,BT,CN,CP,CT,DC,DE,DN,EI,EN,EP,EQ,ES,FT,GE,GR,NA,PC,PD,PG Dim RA,RT,RAK,RB,RTK,SAA,SAL,SAR,SC,SCP,SD,SH,SSH,SN,SNA,ST,TC,TD,TN,UN,VA,VK,YR Set Track=iTunes.LibraryPlaylist.Tracks.ItemByPersistentID(H,L) With Track If Prog Then PB.Progress N+.25,Count D=.Name & " by " & .Artist & "
" PB.SetInfo D & "Saving data" WScript.Sleep 100 End If Path=.Location Ext=LCase(Right(Path,4)) ' Record volatile metadata here, all file types EN=.Enabled UN=.Unplayed RA=.AlbumRating RAK=.AlbumRatingKind RT=.Rating RTK=.RatingKind ' Record extra data for files without tags If Instr("mpeg.mid.mov.mpg.pdf.wav",Ext)>0 Then TN=.TrackNumber TC=.TrackCount DN=.DiscNumber DC=.DiscCount YR=.Year CN=.Compilation PG=.PartOfGaplessAlbum NA=.Name AR=.Artist AA=.AlbumArtist AL=.Album CP=.Composer CT=.Comment GE=.Genre GR=.Grouping End If ' The AIF tag only records partial data, save the rest here, along with data for other non-tag formats If Instr("mpeg.aif.mid.mov.mpg.pdf.wav",Ext)>0 Then VK=.VideoKind SN=.SeasonNumber EP=.EpisodeNumber EI=.EpisodeID SH=.Show DE=.Description SNA=.SortName SAR=.SortArtist SAA=.SortAlbumArtist SAL=.SortAlbum SCP=.SortComposer SSH=.SortShow End If ' Record extra data for media file types If Instr("itlp.ite.pdf",Ext)=0 Then PC=.PlayedCount PD=.PlayedDate SC=.SkippedCount SD=.SkippedDate VA=.VolumeAdjustment EQ=.EQ ST=.Start FT=.Finish TD=.Duration RB=.RememberBookmark BT=.BookmarkTime ES=.ExcludeFromShuffle End IF ' Note playlist membership Set Playlists=.Playlists End With ' Delete the track from the library If Prog Then PB.Progress N+.5,Count PB.SetInfo D & "Saving data - Removing file" WScript.Sleep 100 End If StartEvent Track.Delete StopEvent ' Ensure at least 1 second has passed since last track was added Do Loop Until Int(Timer)<>LT ' Use <> in case of timer reset at midnight... ' Reimport the track into the library If Prog Then PB.Progress N+.75,Count PB.SetInfo D & "Saving data - Removing file - Adding file" WScript.Sleep 100 End If StartEvent Set Status=iTunes.LibraryPlaylist.AddFile(path) StopEvent ' Note current time LT=INT(Timer) If IsNull(Status) Then MsgBox "There was a problem reimporting the file " & nl & path,0,Title Else Do While Status.InProgress WScript.Sleep 100 Loop If Status.Tracks.Count=0 Then MsgBox "No track!" Set Track=Status.Tracks(1) If Prog Then PB.Progress N+1,Count PB.SetInfo D & "Saving data - Removing file - Adding file - Restoring data" WScript.Sleep 100 End If ' Reinsert track into non-smart user playlists StartEvent For I=1 To Playlists.Count If Playlists.Item(I).Kind=2 And Playlists.Item(I).Smart=False Then 'MsgBox Playlists.Item(I).Name Playlists.Item(I).AddTrack(Track) End If Next ' Restore volatile meta data here With Track ' Restore stats/playback options for media files only If Instr("itlp.ite.pdf",Ext)=0 Then '.PlayedCount=PC Retry Track,PC ' Try to set PlayedCount property, loop until successful... ' Ignore potential errors while setting various media track properties On Error Resume Next If PD>0 Then .PlayedDate=DateAdd("n",TimeFactor*60,PD) .SkippedCount=SC If SD>0 Then .SkippedDate=DateAdd("n",TimeFactor*60,SD) .VolumeAdjustment=VA If EQ<>"" Then .EQ=EQ .Start=ST If TD>FT Then .Finish=FT If RB Then .RememberBookmark=RB .BookmarkTime=BT End If .ExcludeFromShuffle=ES 'S=1/0 'Dummy error for testing If Err.Number<>0 Then S="An error occured while restoring a property of:" & nl & .location & nl & nl S=S & "Error:" & tab & Err.Description & nl S=S & "Code:" & tab & Right("0000000" & Err.Number,8) & nl & nl S=S & "Press OK to resume or Cancel to abort." ' Comment out the following line to ignore all errors in this section R=MsgBox(S,vbOKCancel+vbInformation,Title) : If R=vbCancel Then Quit=True Err.Clear End If ' Restore normal error handling On Error Goto 0 End If ' Restore general iTunes specific/non-tag data .Enabled=EN .Unplayed=UN If RAK=0 Then .AlbumRating=RA ' Don't restore computed ratings If RTK=0 Then .Rating=RT ' Don't restore computed ratings ' Restore extra data for files without tags If Instr("mpeg.mid.mov.mpg.pdf.wav",Ext)>0 Then .TrackNumber=TN .TrackCount=TC .DiscNumber=DN .DiscCount=DC .Year=YR .Compilation=CN If ext=".wav" Then .PartOfGaplessAlbum=PG If NA<>"" Then .Name=NA If AR<>"" Then .Artist=AR If AA<>"" Then .AlbumArtist=AA If AL<>"" Then .Album=AL If CP<>"" Then .Composer=CP If CT<>"" Then .Comment=CT If GE<>"" Then .Genre=GE If GR<>"" Then .Grouping=GR End If ' The AIF tag only records partial data, restore the rest here, along with data for other non-tag formats If Instr("mpeg.aif.mid.mov.mpg.pdf.wav",ext)>0 Then ' MsgBox "VideoKind = " & VK If VK>0 Then .VideoKind=VK If ext<>".pdf" THEN .SeasonNumber=SN ' Can't set these two values for PDF's from script If ext<>".pdf" THEN .EpisodeNumber=EP ' although they can be set via iTunes Get Info. :( If EI<>"" Then .EpisodeID=EI If SH<>"" Then .Show=SH If DE<>"" Then .Description=DE If SNA<>"" Then .SortName=SNA If SAR<>"" Then .SortArtist=SAR If SAA<>"" Then .SortAlbumArtist=SAA If SAL<>"" Then .SortAlbum=SAL If SCP<>"" Then .SortComposer=SCP If SSH<>"" Then .SortShow=SSH End If End With StopEvent U=U+1 ' Increment processed tracks End If End Sub ' Get active time zone offset from GMT ' Modified 2011-10-04 Function TZOffset Dim Shell Set Shell=CreateObject("WScript.Shell") TZOffset=Shell.RegRead("HKEY_LOCAL_MACHINE\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")/60 End Function ' ============================================ ' Reusable Library Routines for iTunes Scripts ' ============================================ ' Modified 2011-11-13 ' 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 ' Initialise track selections, quit script if track selection is out of bounds or user aborts ' Modified 2011-11-13 Sub GetTracks Dim Q,R ' Initialise global variables nl=vbCrLf : tab=Chr(9) : Quit=False M=0 : P=0 : S=0 : U=0 : V=0 ' Initialise global objects Set iTunes=CreateObject("iTunes.Application") Set Tracks=iTunes.SelectedTracks ' Get current selection If iTunes.BrowserWindow.SelectedPlaylist.Source.Kind<>1 And Source="" Then Source="Library" : Named=True ' Ensure section is from the library source 'If iTunes.BrowserWindow.SelectedPlaylist.Name="Ringtones" And Source="" Then Source="Library" : Named=True ' and not ringtones (which cannot be processed as tracks???) If iTunes.BrowserWindow.SelectedPlaylist.Name="Radio" And Source="" Then Source="Library" : Named=True ' or radio stations (which cannot be processed as tracks) If iTunes.BrowserWindow.SelectedPlaylist.Name=Playlist And Source="" Then Source="Library" : Named=True ' or a playlist that will be regenerated by this script If Named Or Tracks Is Nothing Then ' or use a named playlist If Source<>"" Then Named=True If Source="Library" Then ' Get library playlist... Set Tracks=iTunes.LibraryPlaylist.Tracks Else ' or named playlist On Error Resume Next ' Attempt to fall back to current selection for non-existent source Set Tracks=iTunes.LibrarySource.Playlists.ItemByName(Source).Tracks On Error Goto 0 If Tracks is Nothing Then ' Fall back Named=False Source=iTunes.BrowserWindow.SelectedPlaylist.Name Set Tracks=iTunes.SelectedTracks If Tracks is Nothing Then Set Tracks=iTunes.BrowserWindow.SelectedPlaylist.Tracks End If End If End If End If If Named And Tracks.Count=0 Then ' Quit if no tracks in named source If Intro Then MsgBox "The playlist " & Source & " is empty, there is nothing to do.",vbExclamation,Title WScript.Quit End If If Tracks.Count=0 Then Set Tracks=iTunes.LibraryPlaylist.Tracks If Tracks.Count=0 Then ' Can't select ringtones as tracks? MsgBox "This script cannot process " & iTunes.BrowserWindow.SelectedPlaylist.Name & ".",vbExclamation,Title WScript.Quit End If ' Check there is a suitable number of suitable tracks to work with Count=Tracks.Count 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 Q=Summary If Q<>"" Then Q=Q & nl & nl If Warn>0 And Count>Warn Then Intro=True Q=Q & "WARNING!" & nl & "Are you sure you want to process " & Count & " tracks" If Named Then Q=Q & nl Else Q=Q & "Process " & Count & " track" & Plural(Count,"s "," ") End If If Named Then Q=Q & "from the " & Source & " playlist" Q=Q & "?" If Intro Or (Prog And UAC) Then If Check Then Q=Q & nl & nl Q=Q & "Yes" & tab & ": Process track" & Plural(Count,"s","") & " automatically" & nl Q=Q & "No" & tab & ": Preview & confirm each action" & nl Q=Q & "Cancel" & tab & ": Abort script" End If If Kimo Then Q=Q & nl & nl & "NB: Disable ''Keep iTunes Media folder organised'' preference before use." If Prog And UAC Then Q=Q & nl & nl & "NB: Disable User Access Control to allow progess bar to operate" & nl Q=Q & "or change the declaration ''Prog=True'' to ''Prog=False''." Prog=False End If 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 If Check Then Prog=False ' Suppress progress bar if prompting for user input 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 ' Loop through track selection processing suitable items ' Modified 2011-11-06 Sub ProcessTracks Dim C,I,N,Q,R,T N=0 If Prog Then ' Create ProgessBar Set PB=New ProgBar PB.SetTitle Title PB.Show End If Clock=0 : StartTimer For I=Count To 1 Step -1 ' Work backwards in case edit removes item from selection N=N+1 If Prog Then PB.SetStatus Status(N) PB.Progress N-1,Count End If Set T=Tracks.Item(I) If Prog Then PB.SetInfo Info(T) If T.Kind=1 Then ' Ignore tracks which can't change If Updateable(T) Then ' Ignore tracks which won't change If Check Then ' Track by track confirmation Q=Prompt(T) StopTimer ' Don't time user inputs R=MsgBox(Q,vbYesNoCancel+vbQuestion,Title) StartTimer Select Case R Case vbYes C=True Case vbNo C=False S=S+1 ' Increment skipped tracks Case Else Quit=True Exit For End Select Else C=True End If If C Then ' We have a valid track, now do something with it Action T End If Else If T.Location<>"" Then V=V+1 ' Increment unchanging tracks, exclude missing ones End If End If P=P+1 ' Increment processed tracks If Quit Then Exit For ' Abort loop on user request Next StopTimer If Prog And Not Quit Then PB.Progress Count,Count WScript.Sleep 500 PB.Close End If End Sub ' Output report ' Modified 2011-10-24 Sub Report If Not Outro Then Exit Sub Dim T If Quit Then T="Script aborted!" & nl & nl Else T="" T=T & P & " track" & Plural(P,"s","") If P0 Then T=T & V & " did not need updating" If (U>0)+(S>0)+(M>0)<-1 Then T=T & "," & nl ElseIf (U>0)+(S>0)+(M>0)=-1 Then T=T & " and" & nl End If End If If U>0 Or V=0 Then T=T & U & Plural(U," were"," was") & " updated" If (S>0)+(M>0)<-1 Then T=T & "," & nl ElseIf (S>0)+(M>0)=-1 Then T=T & " and" & nl End If End If If S>0 Then T=T & S & Plural(S," were"," was") & " skipped" If M>0 Then T=T & " and" & nl End If If M>0 Then T=T & M & Plural(M," were"," was") & " missing" T=T & "." If Timing Then T=T & nl & nl If Check Then T=T & "Processing" Else T=T & "Running" T=T & " time: " & FormatTime(Clock) End If MsgBox T,vbInformation,Title End Sub ' Start timing event ' Modified 2011-10-08 Sub StartEvent T2=Timer End Sub ' Start timing session ' Modified 2011-10-08 Sub StartTimer T1=Timer End Sub ' Stop timing event and display elapsed time in debug section of Progress Bar ' Modified 2011-11-07 Sub StopEvent If Prog Then T2=Timer-T2 If T2<0 Then T2=T2+86400 ' Watch for timer running over midnight If Debug Then PB.SetDebug "
Last iTunes call took " & FormatTime(T2) End If 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 ' Detect if User Access Control is enabled, UAC prevents use of progress bar ' Modified 2011-10-18 Function UAC Const HKEY_LOCAL_MACHINE=&H80000002 Const KeyPath="Software\Microsoft\Windows\CurrentVersion\Policies\System" Const KeyName="EnableLUA" Dim Reg,Value Set Reg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") ' Use . for local computer, otherwise could be computer name or IP address Reg.GetDWORDValue HKEY_LOCAL_MACHINE,KeyPath,KeyName,Value ' Get current property If IsNull(Value) Then UAC=False Else UAC=(Value<>0) End Function ' ================== ' Progress Bar Class ' ================== ' Progress/activity bar for vbScript implemented via IE automation ' Can optionally rebuild itself if closed or abort the calling script ' Modified 2011-10-18 Class ProgBar Public Cells,Height,Width,Respawn,Title,Version Private Active,Blank,Dbg,Filled(),FSO,IE,Info,NextOn,NextOff,Status,SHeight,SWidth,Temp ' User has closed progress bar, abort or respwan? ' Modified 2011-10-09 Public Sub Cancel() If Respawn And Active Then Active=False If Respawn=1 Then Show ' Ignore user's attempt to close and respawn Else Dim R StopTimer ' Don't time user inputs R=MsgBox("Abort Script?",vbExclamation+vbYesNoCancel,Title) StartTimer If R=vbYes Then On Error Resume Next CleanUp Respawn=False Quit=True ' Global flag allows main program to complete current task before exiting Else Show ' Recreate box if closed End If End If End If End Sub ' Delete temporary html file ' Modified 2011-10-04 Private Sub CleanUp() FSO.DeleteFile Temp ' Delete temporary file End Sub ' Close progress bar and tidy up ' Modified 2011-10-04 Public Sub Close() On Error Resume Next ' Ignore errors caused by closed object If Active Then Active=False ' Ignores second call as IE object is destroyed IE.Quit ' Remove the progess bar CleanUp End If End Sub ' Initialize object properties ' Modified 2011-10-16 Private Sub Class_Initialize() Dim I,Items,strComputer,WMI ' Get width & height of screen for centering ProgressBar strComputer="." Set WMI=GetObject("winmgmts:\\" & strComputer & "\root\cimv2") Set Items=WMI.ExecQuery("Select * from Win32_OperatingSystem",,48) 'Get the OS version number (first two) For Each I in Items Version=Left(I.Version,3) Next Set Items=WMI.ExecQuery ("Select * From Win32_DisplayConfiguration") For Each I in Items SHeight=I.PelsHeight SWidth=I.PelsWidth Next If Debug Then Height=140 ' Height of containing div Else Height=100 ' Reduce height if no debug area End If Width=300 ' Width of containing div Respawn=True ' ProgressBar will attempt to resurect if closed Blank=String(50,160) ' Blanks out "Internet Explorer" from title Cells=25 ' No. of units in ProgressBar, resize window if using more cells ReDim Filled(Cells) ' Array holds current state of each cell For I=0 To Cells-1 Filled(I)=False Next NextOn=0 ' Next cell to be filled if busy cycling NextOff=Cells-5 ' Next cell to be cleared if busy cycling Dbg=" " ' Initital value for debug text Info=" " ' Initital value for info text Status=" " ' Initital value for status text Title="Progress Bar" ' Initital value for title text Set FSO=CreateObject("Scripting.FileSystemObject") ' File System Object Temp=FSO.GetSpecialFolder(2) & "\ProgBar.htm" ' Path to Temp file End Sub ' Tidy up if progress bar object is destroyed ' Modified 2011-10-04 Private Sub Class_Terminate() Close End Sub ' Display the bar filled in proportion X of Y ' Modified 2011-10-18 Public Sub Progress(X,Y) Dim F,I,L,S,Z If X<0 Or X>Y Or Y<=0 Then MsgBox "Invalid call to ProgessBar.Progress, variables out of range!",vbExclamation,Title Exit Sub End If Z=Int(X/Y*(Cells)) If Z=NextOn Then Exit Sub If Z=NextOn+1 Then Step False Else If Z>NextOn Then F=0 : L=Cells-1 : S=1 Else F=Cells-1 : L=0 : S=-1 End If For I=F To L Step S If I>=Z Then SetCell I,False Else SetCell I,True End If Next NextOn=Z End If End Sub ' Clear progress bar ready for reuse ' Modified 2011-10-16 Public Sub Reset Dim C For C=Cells-1 To 0 Step -1 IE.Document.All.Item("P",C).classname="empty" Filled(C)=False Next NextOn=0 NextOff=Cells-5 End Sub ' Directly set or clear a cell ' Modified 2011-10-16 Public Sub SetCell(C,F) On Error Resume Next ' Ignore errors caused by closed object If F And Not Filled(C) Then Filled(C)=True IE.Document.All.Item("P",C).classname="filled" ElseIf Not F And Filled(C) Then Filled(C)=False IE.Document.All.Item("P",C).classname="empty" End If End Sub ' Set text in the Dbg area ' Modified 2011-10-04 Public Sub SetDebug(T) On Error Resume Next ' Ignore errors caused by closed object Dbg=T IE.Document.GetElementById("Debug").InnerHTML=T End Sub ' Set text in the info area ' Modified 2011-10-04 Public Sub SetInfo(T) On Error Resume Next ' Ignore errors caused by closed object Info=T IE.Document.GetElementById("Info").InnerHTML=T End Sub ' Set text in the status area ' Modified 2011-10-04 Public Sub SetStatus(T) On Error Resume Next ' Ignore errors caused by closed object Status=T IE.Document.GetElementById("Status").InnerHTML=T End Sub ' Set title text ' Modified 2011-10-04 Public Sub SetTitle(T) On Error Resume Next ' Ignore errors caused by closed object Title=T IE.Document.Title=T & Blank End Sub ' Create and display the progress bar ' Modified 2011-10-17 Public Sub Show() Const HKEY_CURRENT_USER=&H80000001 Const KeyPath="Software\Microsoft\Internet Explorer\Main\FeatureControl\FEATURE_LOCALMACHINE_LOCKDOWN" Const KeyName="iexplore.exe" Dim File,I,Reg,State,Value Set Reg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") ' Use . for local computer, otherwise could be computer name or IP address 'On Error Resume Next ' Ignore possible errors ' Make sure IE is set to allow local content, at least while we get the Progress Bar displayed Reg.GetDWORDValue HKEY_CURRENT_USER,KeyPath,KeyName,Value ' Get current property State=Value ' Preserve current option Value=0 ' Set new option Reg.SetDWORDValue HKEY_CURRENT_USER,KeyPath,KeyName,Value ' Update property 'If Version<>"5.1" Then Prog=False : Exit Sub ' Need to test for Vista/Windows 7 with UAC Set IE=WScript.CreateObject("InternetExplorer.Application","Event_") Set File=FSO.CreateTextFile(Temp, True) With File .WriteLine "" .WriteLine "" & Title & Blank & "" .WriteLine "" .WriteLine "" .WriteLine "" .WriteLine "
" .WriteLine "" .WriteLine "
" & Status & "
" .WriteLine "" ' Write out cells For I=0 To Cells-1 If Filled(I) Then .WriteLine "" Else .WriteLine "" End If Next .WriteLine "
  
" .WriteLine "
" .WriteLine "" & Info & "
" .WriteLine "" & Dbg & "
" .WriteLine "
" End With ' Create IE automation object with generated HTML With IE .width=Width+30 ' Increase if using more cells .height=Height+55 ' Increase to allow more info/debug text If Version>"5.1" Then ' Allow for bigger border in Vista/Widows 7 .width=.width+10 .height=.height+10 End If .left=(SWidth-.width)/2 .top=(SHeight-.height)/2 .navigate "file://" & Temp '.navigate "http://samsoft.org.uk/progbar.htm" .addressbar=False .menubar=False .resizable=False .toolbar=False On Error Resume Next .statusbar=False ' Causes error on Windows 7 or IE 9 On Error Goto 0 .visible=True ' Causes error if UAC is active End With Active=True ' Restore the user's property settings for the registry key Value=State ' Restore option Reg.SetDWORDValue HKEY_CURRENT_USER,KeyPath,KeyName,Value ' Update property Exit Sub End Sub ' Increment progress bar, optionally clearing a previous cell if working as an activity bar ' Modified 2011-10-05 Public Sub Step(Clear) SetCell NextOn,True : NextOn=(NextOn+1) Mod Cells If Clear Then SetCell NextOff,False : NextOff=(NextOff+1) Mod Cells End Sub ' Self-timed shutdown ' Modified 2011-10-05 Public Sub TimeOut(S) Dim I Respawn=False ' Allow uninteruppted exit during countdown For I=S To 2 Step -1 SetDebug "
Closing in " & I & " seconds" & String(I,".") WScript.sleep 1000 Next SetDebug "
Closing in 1 second." WScript.sleep 1000 Close End Sub End Class ' Fires if progress bar window is closed, can't seem to wrap up the handler in the class ' Modified 2011-10-04 Sub Event_OnQuit() PB.Cancel End Sub ' ============== ' End of listing ' ==============