' ========= ' TitleCase ' ========= ' Version 1.0.0.15 - October 6th 2017 ' Copyright © Steve MacGuire 2011-2017 ' http://samsoft.org.uk/iTunes/TitleCase.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 ' =========== ' Change text in Album, AlbumArtist, Artist, Composer, and Name fields into Title Case ' ========= ' ChangeLog ' ========= ' Version 1.0.0.1 - Initial version, update track Name only ' Version 1.0.0.2 - Extend to Album, AlbumArtist, Artist and Name fields ' Version 1.0.0.3 - Added more exceptions ' Version 1.0.0.4 - Optional lower case list ' Version 1.0.0.5 - Options for fields to fix, includes Composer ' Version 1.0.0.6 - Cache previous results for speed ' Version 1.0.0.7 - More tweaks and exceptions ' Version 1.0.0.8 - Even more tweaks and exceptions, extend to Show field ' Version 1.0.0.9 - Add rule to remove spaces around slash character ' Version 1.0.0.10 - Add rule to change () to [] around keywords such as Feat. and Live ' Version 1.0.0.11 - Various updates to exception lists ' Version 1.0.0.12 - Fix for non-breaking spaces ' Version 1.0.0.13 - Various updates to exception lists ' Version 1.0.0.14 - Various updates to exception lists, fix errors caused by streams ' ========== ' To-do List ' ========== ' Add things to do ' Remember choices in track by track confirmation mode... ' E.g. if "THIS"->"This" has been approved once don't ask again and do automatically. If not approved, skip automatically. ' ============================= ' Declare constants & variables ' ============================= ' Variables for common code ' Modified 2014-04-09 Option Explicit ' Declare all variables before use 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 ' Values for common code ' Modified 2014-04-26 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 Intro=True ' Set false to skip initial prompts, avoid if non-reversible actions Outro=True ' Produce summary report Check=True ' Track-by-track confirmation, can be set during Intro Prog=True ' Display progress bar, may be disabled by UAC/LUA settings 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 Rev=False ' Control processing order, usually reversed Debug=True ' Include any debug messages in progress bar Tracing=True ' Display tracing message boxes Title="Title Case" Summary="Change text in Album, AlbumArtist, Artist, Composer, and Name fields into Title Case." ' Additional variables for this particular script ' Modified 2017-05-17 ' Exception lists Dim Cons,Ignore,Lower,Mixed,Precache,Precons,Replist,Roman,Splits,ThisThat,Upper ' Extend contractions/stubs list here, these will be lower case after characters in the Precons list, e.g. Cons="|a|acte|alfpenny|ali|ave|b|bal|boogie|bout|c|cha|day|dino|ee|em|en|er|ers|es|est|g|gen|il|in|int|io|ko|lin|ll|lly|m|ma|mma|mon|n|na|naan|nd|nérd|nuff|obi|omalu|ombe|rd|re|ree|reen|rence|rent|rin|ring|ron|ry|rybody|s|se|st|t|tcha|tchu|th|ths|ubaba|uckas|ve|z|zar|" ' Extend ignore list here, these words will retain their current case, need manually correcting by context and/or personal preference Ignore="|ABS|Ad|Am|BlackBox|CAB|Carp|Cc|Cellos|Com|D|Db|del|DiscOZone|epnm|EZ|FA|FAD|Ha|ing|Id|Jive|JoJo|K|KB|LAX|Lol|MIDI|MK|MM|Ng|Ny|OU|PLC|Pm|POD|Pt|Rip|SAS|SE|SOiL|St|SU|SY|til|tin|Ur|Us|Ut|van|Vi|von|WA|Wasp|WOW|XO|XS|y|ZEN|" ' Extend lower case list here, if needed, also needs to be enabled below Lower="|a|an|and|at|cha|de|del|di|du|e|el|en|et|for|from|in|la|le|of|or|por|the|to|un|une|und|with|y|" ' Extend mixed case list here, these are forced to the values listed Mixed="|AnonPBear|AnounymOS|AnotherLateNight|BBMak|BodyRockers|bretonLABS|CeCe|CrazySexyCool|DarkMateria|DiFiore|DragonForce|DreamWorks|dZihan|djhardwell|DJMovesSuperClubMegamix|DJs|DubHQ|EthnoTech|FreQ|GarageBand|GLaDOS|GusGus|HtwoO|iBooks|InfiniDim|iiO|InMe|iOS|iPad|iPhone|iPod|iPodRip|IraqThumping|iRiver|iTalk|iTunes|KayJay|kHz|MachoPsycho|MasterChef|MasteryTV|MCs|MoonQuest|NuBreed|OneRepublic|OutKast|ParaNorman|PCs|PinkGator|pH|PhD|PoleJR|PopChop|ProGen|QKThr|REDALiCE|RikRok|RnBXclusive|RoboCop|RocknRolla|SonicWALL|StoneBridge|TEDTalks|thematrix|TwentyFourSeven|UFC|UFOs|VIIa|VIIb|VIIc|VonStroke|WBallz|WinAmp|www|xxmas|YouTube|" ' Complete strings and their replacements, use to force a change or prevent an unwanted one Precache="|Christmas Eve / Sarajevo 12/24 [Instrumental]\Christmas Eve / Sarajevo 12/24 [Instrumental]|Close (To The Edit)\Close (To The Edit)|Close (To The Edit) [Album Version]\Close (To The Edit) [Album Version]|Crossroads 2 (Live In The Seventies)\Crossroads 2 (Live In The Seventies)|Deja Vu\Déjà Vu|Derek & Clive (Live)\Derek & Clive (Live)|ETC\ETC|LA\LA|OWLs\OWLs|Race For Space / Remixes\Race For Space / Remixes|$O$\$O$|Sputnik / Korolev\Sputnik / Korolev|Ten$Ion\Ten$Ion|The Race For Space / Remixes\The Race For Space / Remixes|x\x|xx\xx|( )\( )|" ' List of characters that come before contractions Precons="’'0123456789*#" ' Extend list of custom replacements here, these can include punctuation & numerals Replist="|'A'|a-ha|A-Ha Ha|A-Hap|Abba Zaba|alt-J|apl.de.ap|AT&T|AUDIO0|'B'|B'Day|Ba-Lue|Ba-Lues-Are|B-JU|blink-182|B.o.B|Blues In LA|B2K|-cut|(c)|'C'|CD2A|CD2B|CD5A|CD5B|C'e.|c-ed After Dark|Chali 2na|CHERUB:|Ching-a-Ling|CiSTM K0nFLiqT|C-lebrity|{CLIPPED}|CODA Remix|(d)|'D'|deadmau5|de Beauport|de Burgh|de Ceballos|de Fries|de Homem|de Jesus|de la Rocha|de Lucía|de Manchaut|de Martino|de Meyer|de Monjes|de Moraes|de Morales|de Moor|de Rore|de Rose|de Santo|de Sermisy|de Silos|de Vlieger|de Vorzon|den Adel|D'Un|FA MP40|Good'un|du Berry|DioGuardi|D'yer|di Battista|-ee|-esque|EV3|[EXTENDED Fun||Fu*k|FutureSex|G4orce|GoodBooks|Ha-Ha|IMG_|'In'|Int'l|I-DEF-I|ION Fundamentals|ION Operations|iSelect|IT Crowd|jim james 'apple C'|j00f|J.P.P. Mc|janet.|k.d. lang|Keali'i|Kill 'Em All|**kin|km/h|Knock-down Drag-out|Knoc-turn'al|k-os|Kyur4 th Ich|LA Breakdown|LA Drone|LeftRightLeftRightLeft|Lemonjelly.ky|Live In LA|Li'l|LL Cool J|LoveGame|LoveSound|LoveStoned|LunaSol|'M'|M!ssundaztood|-Midi|MI7|My LA Ex|Mac OS X|NOW That's What I Call Polka!|Overtly-ture|P5hng Me A*wy|, or, |Op:l|OSC-DIS|PAT2000|P!nk|Pe'me|Pop!ular|Pts.OF.Athrty|Quelqu'un|?uestlove|Qur'an|R'n'B|Radio:ACTIVE|Re-edits|(RED)|RedOne|{RUDE}|Rnw@y|RW6|S7evon|(S)aint|$Copie|SexyBack|Sh.Fe.Mc's|SI.Ahn|(sic)|Sin-é|Sk8er|Smile.dk|Streamin' Freq.|-take|t.A.T.u.|TED:|Thnks Fr|The xx|Trav'ling|Tutt'amor|Unkle Ho|VOICE0|VL3000|What(ever)|while(1<2)|will.i.am|X-Ecutioner Style|xx Edit|Yer 'and|YoungBloodZ|YR Garrido|1stp Klosr|10x10|2wayforyou|3OH!3|3x5|4x4|4hero|5ive|7chan|8fatfat8|[16B Remix]|" ' Extend Roman numeral list here Roman="|II|III|IV|V|VII|VIII|IX|XI|XII|XIII|XIV|XV|XVI|XVII|XVIII|XIX|XX|XXI|XXII|XXIII|XXIV|XXV|XL|MCMXC|" ' List of characters that indicate word boundaries Splits=" .,:;‘’`´“”'""()[]{}<>/\|!?¡¿-_+*&=0123456789·•°~#" ' Pairs of specific words and their replacements, can match on following punctuation, case sensitive ThisThat="|Featuring\Feat.|Ft.\Feat. |Pt \Part |Pt.\Part |pt.\Part |Pts \Parts " ' Extend upper case list here Upper="|AA|AAC|ABBA|AB|ABC|AC|ADF|AF|AFI|AGH|AIFF|AKA|AOI|AMD|ATB|ATFC|ATL|AZ|AZN|BB|BBC|BBM|BC|BBE|BECTU|BIMM|BJ|BK|BM|BMF|BNC|BOC|BRS|BS|BT|BTK|BTO|BWO|BWV|BYOB|CBS|CCS|CCTV|CD|CDFF|CDM|CDP|CF|CG|CJ|CKY|CL|CM|CMC|CMT|CPO|CRC|CRW|CSI|CSS|CSX|CT|CZR|DC|DD|DDR|DF|DIY|DJ|DLC|DLG|DM|DMX|DMZ|DNA|DND|DNS|DOA|DT|EA|EERA|EFX|ELO|EMF|EMI|EP|EPMD|ESCM|ESP|ESPN|EXP|FBI|FC|FFV|FL|FM|FMS|FNP|FPI|FR|FSUK|FTL|FX|FYD|GE|GG|GHV|GP|GTA|HBO|HCCR|HMV|HQ|HS|HW|HWV|IACGMOOH|IAO|IB|IC|INXS|IOU|IQ|ITO|JB|JC|JCB|JD|JDS|JJ|JP|JLS|JLW|JME|JS|JTK|JVC|JXL|KC|KCRW|KEXP|KHG|KHSU|KKK|KLF|KLM|KMET|KP|KROQ|KRS|KT|KV|KVRX|KYEO|LCD|LDN|LFO|LMC|LMFAO|LNDP|LOX|LP|LSD|LSG|LSK|LTJ|LV|LW|LWH|LX|MARRS|MAW|MC|MCA|MF|MFC|MFSB|MG|MGM|MGMT|MJ|MLF|MMHMM|MOP|MOV|MP|MPB|MPC|MSTRKRFT|MTV|MV|MVP|MX|MXPX|MYNC|MZ|NASA|NBC|NFL|NHS|NJ|NMCB|NME|NMJ|NMR|NNN|NOFX|NPR|NRG|NUXX|NW|NYC|NZA|OAM|OK|OMD|OMG|OST|PC|PCD|PD|PDA|PE|PF|PHP|PJ|PLC|PMS|PMT|PNC|POV|PP|PPA|PPK|PSB|PTA|PTQ|PVD|QFX|RAF|RBX|RC|REO|RG|RJ|RJD|RPM|RR|RS|RU|RV|RZA|SARM|SD|SDP|SDR|SFX|SG|SK|SKL|SLK|SPL|SOLT|SOS|SRXT|SS|SSS|SV|SWP|SWR|SWV|SXSW|SYSLJFM|TB|TBS|TC|TGV|THX|TKO|TLC|TLND|TM|TNT|TT|TV|TVC|TW|TWV|TX|TYR|UB|UBQ|UD|UDAUFL|UFO|UK|UKO|UMF|UNKLE|USA|USM|USSR|VCR|VH|VIP|VW|WAAF|WAPL|WAV|WBCN|WFMU|WJ|WP|WRMS|WS|WTF|WTFF|XD|XFM|XOX|XP|XTC|XXL|XXX|YMCA|YMO|YYY|ZZ|2XS|" ' Control Flags Dim FixAA,FixAl,FixAr,FixCo,FixNa,FixSh,FixAnd,FixBraces,FixQuotes,FixSlash,UseLower FixAL=True ' Apply TitleCase to Album FixAA=True ' Apply TitleCase to Album Artist FixAR=True ' Apply TitleCase to Artist FixCO=True ' Apply TitleCase to Composer FixNA=True ' Apply TitleCase to Name FixSH=True ' Apply TitleCase to Show FixAnd=True ' Change " and " to " & ", except as first word or after " - " FixBraces=True ' Change () to [] around keywords such as Feat. and Live FixQuotes=True ' Change ‘ or ’ to ' and “, ” or '' to " FixSlash=True ' Remove spaces around slash character UseLower=False ' Control use of lower case list ' More initialisation Dim Cache,Words,L Set Cache=CreateObject("Scripting.Dictionary") Set Words=CreateObject("Scripting.Dictionary") Precache=Split(Mid(Precache,2,Len(Precache)-2),"|") Replist=Split(Mid(Replist,2,Len(Replist)-2),"|") ThisThat=Split(Mid(ThisThat,2,Len(ThisThat)-2),"|") For Each L in Precache Cache.Add Left(L,Instr(L,"\")-1),Mid(L,Instr(L,"\")+1) Next For Each L in ThisThat Words.Add Left(L,Instr(L,"\")-1),Mid(L,Instr(L,"\")+1) Next L="" If FixAL Then L=MakeList(L,"Album") If FixAA Then L=MakeList(L,"Album Artist") If FixAR Then L=MakeList(L,"Artist") If FixCO Then L=MakeList(L,"Composer") If FixNA Then L=MakeList(L,"Name") If FixSH Then L=MakeList(L,"Show") If L="" Then MsgBox "No fields are selected for processing, please edit the control flags.",vbCritical,Title : WScript.Quit Summary="Change text in " & L & " field" If Instr(L," and ") Then Summary=Summary & "s" Summary=Summary & " into Title Case." ' ============ ' Main program ' ============ ' Test ' Use to manually test TCase function GetTracks ' Set things up ProcessTracks ' 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 following module and supporting numerous options for track selection, confirmation, progress and results. ' Change text in Album, AlbumArtist, Artist, Composer, Name & Show main/sort fields into Title Case ' Modified 2014-06-01 Sub Action(T) Dim AA,AL,AR,CO,NA,SH,SAA,SAL,SAR,SCO,SNA,SSH With T If FixAL Then AL=TCase(.Album):SAL=TCase(.SortAlbum) If FixAA Then AA=TCase(.AlbumArtist):SAA=TCase(.SortAlbumArtist) If FixAR Then AR=TCase(.Artist):SAR=TCase(.SortArtist) If FixCO Then CO=TCase(.Composer):SCO=TCase(.SortComposer) If FixNA Then NA=TCase(.Name):SNA=TCase(.SortName) If FixSH Then SH=TCase(.Show):SSH=TCase(.SortShow) StartEvent If FixAL Then If AL<>.Album Then .Album=AL If FixAA Then If AA<>.AlbumArtist Then .AlbumArtist=AA If FixAR Then If AR<>.Artist Then .Artist=AR If FixCO Then If CO<>.Composer Then .Composer=CO If FixNA Then If NA<>.Name Then .Name=NA If FixSH Then If SH<>.Show Then .Show=SH If FixAL Then If SAL<>.SortAlbum Then .SortAlbum=SAL If FixAA Then If SAA<>.SortAlbumArtist Then .SortAlbumArtist=SAA If FixAR Then If SAR<>.SortArtist Then .SortArtist=SAR If FixCO Then If SCO<>.SortComposer Then .SortComposer=SCO If FixNA Then If SNA<>.SortName Then .SortName=SNA If FixSH Then If SSH<>.SortShow Then .Show=SSH StopEvent U=U+1 ' Increment updated tracks End With End Sub ' Change () to [] around keywords such as Feat. and Live - Should make use of another user editable list ' Modified 2019-10-05 Function FixBrackets(T) Dim B,P B=T P=Instr(B,"(Acoustic") : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"(BBC") : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"(Bonus") : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"(Edit") : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"(Feat.") : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"(Instrumental") : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"(Live") : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"(Previously") : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"(Remastered") : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"Cover)") : If P>0 Then P=InstrRev(B,"(",P) : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"Dub)") : If P>0 Then P=InstrRev(B,"(",P) : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"Edit)") : If P>0 Then P=InstrRev(B,"(",P) : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"Mix)") : If P>0 Then P=InstrRev(B,"(",P) : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"Remix)") : If P>0 Then P=InstrRev(B,"(",P) : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"Session)") : If P>0 Then P=InstrRev(B,"(",P) : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) P=Instr(B,"Version)") : If P>0 Then P=InstrRev(B,"(",P) : If P>0 Then B=Left(B,P-1) & Replace(B,"(","[",P,1) : B=Left(B,P-1) & Replace(B,")","]",P,1) FixBrackets=B End Function ' Custom info message for progress bar ' Modified 2017-05-17 Function Info(T) Dim A,B With T A="" : B="" On Error Resume Next ' Trap potential error ' NB Adding an empty string prevents assignment errors where value is null A=.AlbumArtist & "" : If A="" Then A=.Artist & "" B=.Album & "" On Error Goto 0 ' Restore standard error handler If A="" Then A="Unknown Artist" If B="" Then B="Unknown Album" Info="Checking: " & A & " - " & B & " - " & .Name End With End Function ' Create a list of words with punctuation ' Modified 2014-04-24 Function MakeList(L,N) If L="" Then MakeList=N Else MakeList=Replace(L," and ",", ") & " and " & N End If End Function ' Custom prompt for track-by-track confirmation ' Modified 2014-07-21 Function Prompt(T) Dim AA,AL,AR,CO,DN,NA,SH,NAA,NAL,NAR,NNA,NCO,NSH,SAA,SAL,SAR,SCO,SNA,SSH,TN,W W=30 With T AL=ShowSpace(.Album) AA=ShowSpace(.AlbumArtist) AR=ShowSpace(.Artist) CO=ShowSpace(.Composer) NA=ShowSpace(.Name) SH=ShowSpace(.Show) If FixAL Then NAL=TCase(.Album) Else NAL=.Album If FixAA Then NAA=TCase(.AlbumArtist) Else NAA=.AlbumArtist If FixAR Then NAR=TCase(.Artist) Else NAR=.Artist If FixCO Then NCO=TCase(.Composer) Else NCO=.Composer If FixNA Then NNA=TCase(.Name) Else NNA=.Name If FixSH Then NSH=TCase(.Show) Else NSH=.Show DN=.DiscNumber : If DN="0" Then DN="" Else If .DiscCount>0 Then DN=DN & " of " & .DiscCount TN=.TrackNumber : If TN="0" Then TN="" Else If .TrackCount>0 Then TN=TN & " of " & .TrackCount Prompt="Update starred properties?" Prompt=Prompt & nl & nl & "Album" & tab & tab & Wrap(AL,W," ",2) : If NAL<>.Album Then Prompt=Prompt & " *" & nl & "->" & tab & tab & Wrap(NAL,W," ",2) If FixAL Then If .SortAlbum<>TCase(.SortAlbum) Then Prompt=Prompt & nl & nl & "Sort Album" & tab & Wrap(ShowSpace(.SortAlbum),W," ",2) & " *" & nl & "->" & tab & tab & Wrap(TCase(.SortAlbum),W," ",2) Prompt=Prompt & nl & nl & "Album Artist" & tab & Wrap(AA,W," ",2) : If NAA<>.AlbumArtist Then Prompt=Prompt & " *" & nl & "->" & tab & tab & Wrap(NAA,W," ",2) If FixAA Then If .SortAlbumArtist<>TCase(.SortAlbumArtist) Then Prompt=Prompt & nl & nl & "Sort Album Artist" & tab & Wrap(ShowSpace(.SortAlbumArtist),W," ",2) & " *" & nl & "->" & tab & tab & Wrap(TCase(.SortAlbumArtist),W," ",2) Prompt=Prompt & nl & nl & "Artist" & tab & tab & Wrap(AR,W," ",2) : If NAR<>.Artist Then Prompt=Prompt & " *" & nl & "->" & tab & tab & Wrap(NAR,W," ",2) If FixAR Then If .SortArtist<>TCase(.SortArtist) Then Prompt=Prompt & nl & nl & "Sort Artist" & tab & tab & Wrap(ShowSpace(.SortArtist),W," ",2) & " *" & nl & "->" & tab & tab & Wrap(TCase(.SortArtist),W," ",2) Prompt=Prompt & nl & nl & "Composer " & tab & Wrap(CO,W," ",2) : If NCO<>.Composer Then Prompt=Prompt & " *" & nl & "->" & tab & tab & Wrap(NCO,W," ",2) If FixCO Then If .SortComposer<>TCase(.SortComposer) Then Prompt=Prompt & nl & nl & "Sort Composer" & tab & Wrap(ShowSpace(.SortComposer),W," ",2) & " *" & nl & "->" & tab & tab & Wrap(TCase(.SortComposer),W," ",2) Prompt=Prompt & nl & nl & "Name" & tab & tab & Wrap(NA,W," ",2) : If NNA<>.Name Then Prompt=Prompt & " *" & nl & "->" & tab & tab & Wrap(NNA,W," ",2) If FixNA Then If .SortName<>TCase(.SortName) Then Prompt=Prompt & nl & nl & "Sort Name" & tab & Wrap(ShowSpace(.SortName),W," ",2) & " *" & nl & "->" & tab & tab & Wrap(TCase(.SortName),W," ",2) If .Show<>"" Then Prompt=Prompt & nl & nl & "Show" & tab & tab & Wrap(SH,W," ",2) : If NSH<>.Show Then Prompt=Prompt & " *" & nl & "->" & tab & tab & Wrap(NSH,W," ",2) If .Show<>"" And FixSH Then If .SortShow<>TCase(.SortShow) Then Prompt=Prompt & nl & nl & "Sort Show" & tab & Wrap(ShowSpace(.SortShow),W," ",2) & " *" & nl & "->" & tab & tab & Wrap(TCase(.SortShow),W," ",2) If DN<>"" Then Prompt=Prompt & nl & nl & "Disc #" & tab & tab & DN If TN<>"" Then Prompt=Prompt & nl & nl & "Track #" & tab & tab & TN End With End Function ' Highlight unwanted spaces ' Modified 2014-04-29 Function ShowSpace(T) ShowSpace=T If Left(T,1)=" " Then ShowSpace="_ " & ShowSpace If Right(T,1)=" " Then ShowSpace=ShowSpace & " _" ShowSpace=Replace(ShowSpace," "," ") End Function ' Custom status message for progress bar ' Modified 2014-04-29 Function Status(N) Status="Processing " & GroupDig(N) & " of " & GroupDig(Count) End Function ' Convert text to Title Case with exceptions and additional tweaks ' Modified 2016-05-28 Function TCase(Text) Dim C,I,L,Q,S,T,W T=Text & "" ' Adding an empty string may help with empty/null values If T="" Then TCase="" ElseIf Cache.Exists(T) Then TCase=Cache.Item(T) ElseIf Len(T)=4 And T=UCase(T) Then TCase=T ' Ignore recovered untagged iPod tracks with 4 uppercase pattern Else TCase="" t=Replace(T,Chr(160)," ") ' Replace non-breaking spaces T=Trim(T) ' Remove leading or trailing spaces If Left(T,1)="'" Then Q=Left(T,1) : T=Mid(T,2) Else Q="" ' Store initial quote for later S=" " ' Initialise last known separator T=T & " " ' Add trailing space to help match contractions and ensure last word is detected properly 'T=Replace(T,",",", ") ' Ensure commas are followed by a space - neat idea, except inside numbers, leave for another time ' Shrink multiple spaces Do While Instr(T," ") T=Replace(T," "," ") Loop ' Edit/enable any preliminary fixes here T=Replace(T,"–","-") ' Replace en dash with dash 'T=Replace(T,"_","-") ' Replace underscore with dash If FixQuotes Then T=Replace(T,"''","""") ' Replace two single quotes with double quote mark T=Replace(T,"“","""") ' Replace "smart" quotes T=Replace(T,"”","""") T=Replace(T,"‘","'") T=Replace(T,"’","'") T=Replace(T,"`","'") T=Replace(T,"´","'") End If T=Replace(T,"( ","(") ' Trim space inside brackets T=Replace(T," )",")") ' Trim space inside brackets 'T=Replace(T," -","-") ' Trim space before dash 'T=Replace(T,"- ","-") ' Trim space after dash 'T=Replace(T,"•","/") ' Custom character swap ' Loop through each word and adjust case Do I=0 L=Len(T) Do I=I+1 Loop Until Instr(Splits,Mid(T,I,1)) Or I=L ' Split on characters that indicate word boundaries W=UCase(Left(T,1)) ' Capitalise initial letter, If I>1 Then W=W & LCase(Mid(T,2,I-2)) ' lower case for the rest If Instr(Precons,S)>0 And Instr(Cons,"|" & LCase(W) & "|")>0 Then W=LCase(W) ' Force contractions to lower case If Instr(LCase(Ignore),"|" & LCase(W) & "|") Then W=Mid(T,1,I-1) ' Retain current case of words in ignore list If I=1 Then S="" Else S=Mid(T,I,1) If Instr(Upper,"|" & UCase(W) & "|") Then W=UCase(W) ' Force certain words to upper case If Instr(Roman,"|" & UCase(W) & "|") Then W=UCase(W) ' Force Roman numerals to upper case, change to LCase if desired ' Retain current case if single uppercase letter after Da,da,De,de,Di,di,Du,du,La,la,Le,le,Ll,lu,Mc,Mac,Van or van If Instr("|Da|De|Di|Du|La|Le|Lu|",Left(W,2)) And Len(W)>3 Then If Mid(T,2,1) & UCase(Mid(W,3,1)) & Mid(T,4,I-4)=Mid(T,2,I-2) Then W=Left(T,I-1) ElseIf Left(W,2)="Mc" And Len(W)>3 Then If "Mc" & UCase(Mid(W,3,1)) & Mid(T,4,I-4)=Left(T,I-1) Then W=Left(T,I-1) ElseIf Left(W,3)="Mac" And Len(W)>4 Then If "Mac" & UCase(Mid(W,4,1)) & Mid(T,5,I-5)=Left(T,I-1) Then W=Left(T,I-1) ElseIf Left(W,3)="Van" And Len(W)>4 Then If "Van" & UCase(Mid(W,4,1)) & Mid(T,5,I-5)=Left(T,I-1) Then W=Left(T,I-1) End If If UseLower Then If Instr(Lower,"|" & LCase(W) & "|") Then W=LCase(W) ' Force certain words to lower case ' Fix special cases for Mixed case here C=Instr(LCase(Mixed),"|" & LCase(W) & "|") : If C Then W=Mid(Mixed,C+1,Len(W)) ' Whole word replacements If Words.Exists(W) Then W=Words.Item(W) ' Add on separator W=W & S ' Whole word replacements that also need to match with the separator If Words.Exists(W) Then W=Words.Item(W) ' Add updated word and separator onto current result TCase=TCase & W ' Update last known separator If I=1 And Instr(Splits,W) Then S=W ' Set up for next loop If I"" Then M=R & " ->" & nl & TCase(R) & nl & nl & M R=InputBox(M,"Title Case") Loop While R<>"" WScript.Quit End Sub ' Custom trace messages for troubleshooting, T is the current track if needed, Null otherwise ' Modified 2014-05-12 Sub Trace(T,M) If Tracing Then Dim R,Q If IsNull(T) Then Q=M & nl & nl Else Q=Info(T) & nl & nl & M & nl & nl End If Q=Q & "Yes" & tab & ": Continue tracing" & nl Q=Q & "No" & tab & ": Skip further tracing" & nl Q=Q & "Cancel" & tab & ": Abort script" R=MsgBox(Q,vbYesNoCancel,Title) If R=vbCancel Then Quit=True : Report : WScript.Quit If R=vbNo Then Tracing=False End If End Sub ' Test for tracks which can be usefully updated ' Modified 2017-05-17 Function Updateable(T) Updateable=False If T.Kind<>1 Then Exit Function ' Can only process file tracks If T.Location & ""="" Then ' Missing files can't be processed by this script Trace T,"No location set." M=M+1 ' Increment missing tracks If Prog Then PB.SetDebug "
Missing file!" : WScript.Sleep 500 Else ' No point updating unchanged values If FixNA Then If T.Name<>TCase(T.Name) Or T.SortName<>TCase(T.SortName) Then Updateable=True : Exit Function If FixAR Then If T.Artist<>TCase(T.Artist) Or T.SortArtist<>TCase(T.SortArtist) Then Updateable=True : Exit Function If FixAA Then If T.AlbumArtist<>TCase(T.AlbumArtist) Or T.SortAlbumArtist<>TCase(T.SortAlbumArtist) Then Updateable=True : Exit Function If FixAL Then If T.Album<>TCase(T.Album) Or T.SortAlbum<>TCase(T.SortAlbum) Then Updateable=True : Exit Function If FixCO Then If T.Composer<>TCase(T.Composer) Or T.SortComposer<>TCase(T.SortComposer) Then Updateable=True If FixSH Then If T.Show<>TCase(T.Show) Or T.SortShow<>TCase(T.SortShow) Then Updateable=True End If End Function ' ============================================ ' Reusable Library Routines for iTunes Scripts ' ============================================ ' Modified 2014-10-07 ' Return lower case file extension with leading . or empty string if no extension ' Modified 2014-06-29 Function Ext(Path) Ext=LCase(FSO.GetExtensionName(Path)) If Ext<>"" Then Ext="." & Ext End Function ' 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 2014-05-05 Sub GetTracks Dim Q,R ' Initialise global variables nl=vbCrLf : tab=Chr(9) : Quit=False D=0 : M=0 : P=0 : S=0 : U=0 : V=0 ' Initialise global objects Set IDs=CreateObject("Scripting.Dictionary") 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 " & GroupDig(Count) & " tracks" If Named Then Q=Q & nl Else Q=Q & "Process " & GroupDig(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: Use the EnableLUA script to allow the progress bar to function" & nl Q=Q & "or change the declaration ''Prog=True'' to ''Prog=False'' to hide this message. " 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 ' Group digits and separate with commas ' Modified 2014-04-29 Function GroupDig(N) GroupDig=FormatNumber(N,0,-1,0,-1) End Function ' Return the persistent object representing the track from its ID as a string ' Modified 2014-09-26 - CLng works better than Eval Function ObjectFromID(ID) Set ObjectFromID=iTunes.LibraryPlaylist.Tracks.ItemByPersistentID(CLng("&H" & Left(ID,8)),CLng("&H" & Right(ID,8))) End Function ' Create a string representing the 64 bit persistent ID of an iTunes object ' Modified 2012-08-24 Function PersistentID(T) PersistentID=Right("0000000" & Hex(iTunes.ITObjectPersistentIDHigh(T)),8) & "-" & Right("0000000" & Hex(iTunes.ITObjectPersistentIDLow(T)),8) End Function ' Return the persistent object representing the track ' Keeps hold of an object that might vanish from a smart playlist as it is updated ' Modified 2017-05-17 Function PersistentObject(T) Dim Ext,L Set PersistentObject=T L="" If T.Kind=1 Then On Error Resume Next ' Trap possible error L=T.Location If Err.Number<>0 Then Trace T,"Error reading location property from object." On Error Goto 0 ' Restore normal error handler End If If L<>"" Then Ext=LCase(Right(L,4)) If Instr(".ipa.ipg.m4r",Ext)=0 Then ' Method below fails for apps, games & ringtones Set PersistentObject=iTunes.LibraryPlaylist.Tracks.ItemByPersistentID(iTunes.ITObjectPersistentIDHigh(T),iTunes.ITObjectPersistentIDLow(T)) End If End If End Function ' 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 2014-04-29 Sub ProcessTracks Dim C,I,N,Q,R,T Dim First,Last,Steps If IsEmpty(Rev) Then Rev=True If Rev Then First=Count : Last=1 : Steps=-1 Else First=1 : Last=Count : Steps=1 End If N=0 If Prog Then ' Create ProgessBar Set PB=New ProgBar PB.SetTitle Title PB.Show End If Clock=0 : StartTimer For I=First To Last Step Steps ' Usually 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) Set T=PersistentObject(T) ' Attach to object in library playlist 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 & " - " & GroupDig(N) & " of " & GroupDig(Count)) 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 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 250 End If If Prog Then PB.Close End Sub ' Output report ' Modified 2014-04-29 Sub Report If Not Outro Then Exit Sub Dim L,T L="" If Quit Then T="Script aborted!" & nl & nl Else T="" 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 S>0 Then L=PrettyList(L,GroupDig(S) & Plural(S," were"," was") & " skipped") If M>0 Then L=PrettyList(L,GroupDig(M) & Plural(M," were"," was") & " missing") T=T & L 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 ' 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 ' 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 (or rather LUA) 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 ' Wrap & tab long strings, break string S after character C working back from up to W characters adding T tabs to each new line ' Modified 2014-09-27 Function Wrap(S,W,C,T) Dim P If Len(S)<=W Then Wrap=S Else P=InstrRev(S,C,W) If P Then Wrap=Left(S,P) & nl & String(T,tab) & Wrap(Mid(S,P+1),W,C,T) End If 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 2014-05-04 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 2012-09-05 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=160 ' Height of containing div Else Height=120 ' 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 2014-05-04 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 "" .WriteLine "" ' New "Mark of the web" .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+35 ' Increase if using more cells .height=Height+60 ' 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 .resizable=False .toolbar=False On Error Resume Next .menubar=False ' Causes error in Windows 8 ? .statusbar=False ' Causes error in 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 uninterrupted 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 ' ==============