'*********************************************************************************
'TITLE: XSPF Playlister
'
'author: charlie craig, craigcharlieATSYMBOLhotmail.com
'date: 02.06.2008
'version: 2.0
'description: XPSF playlist encoder. Processes one folder multiple formats, out
'
'
'BASED ON: Mp3Playlister_singleList.vbs
'orig. author: la_boost@yahoo.com
'found at: www.interclasse.com/scripts/ Mp3Playlister_singleList.php
'orig. date: 13.04.2002
'version: 1.1
'
'*********************************************************************************
'***********************************
'BEGIN
'***********************************
Option Explicit
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, WshShell, cptTot, objArgs, arrFiles(), sExtToGetArr
Dim driveLetter, pathToScan, fold, nTime, sAppName
Set fso = CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")
sAppName = "XPSF Playlister - Recursive playlist generator"
'CC the location that the script should output to
dim outputDir
dim fScript
set fScript = fso.GetFile(WScript.ScriptFullName)
outputDir = fScript.parentFolder.Path
'-- File extensions to include in playlist:
sExtToGetArr = Array("flv","mp3","h264","swf","jpg","png","gif")
'-- playlist file extension
Const sPlaylistExt = "xml"
Set objArgs = WScript.Arguments
if ( objArgs.Count = 0 ) then
WshShell.Popup "You must specify a directory to scan. ", 30, sAppName, 48
WScript.Quit
end if
pathToScan = objArgs(0)
if ucase(left(pathToScan, len(outputDir))) <> ucase(outputDir) then
WshShell.Popup "You may only scan folders that are located in the same directory as this script "& Chr(13) &"(i.e., within """ & outputDir & """).", 30, sAppName, 48
WScript.Quit
end if
nTime = Timer
'-- start scanning
Call startScanning()
'-- clean
Set fso = nothing
Set WshShell = nothing
'***********************************
'END
'***********************************
'***********************************
'FUNCTIONS:
'***********************************
Sub startScanning()
Dim i, cpt, playlistPath
cptTot = 0
If fso.FolderExists(pathToScan) Then
ReDim arrFiles(0)
Set fold = fso.Getfolder(pathToScan)
playlistPath = outputDir &"\"& "playlist" & "." & sPlaylistExt
'CC old playlistPath = fold.path &"\"& fold.Name & "." & sPlaylistExt
'-- recurse folder
Call DoIt(fold)
Else
WshShell.Popup "This script only works with folders. It cannot process """& pathToScan &""".", 5, sAppName, 48
Wscript.quit
End If
'-- save playlist if more than 0 entry in it
If (UBound(arrFiles) > 0) Then
Call Quicksort(arrFiles,0,cptTot-1)
'CC In order to have randomized output, uncomment the following "Randomizer Function" section.
' Me, I prefer randomness.
'
'***********************************
' Randomizer Function
'***********************************
'
'Dim intRnd, AryRnd(), arrDupe(), x, z, bexists
'z = 0
'Randomize
'ReDim AryRnd(0)
'ReDim arrDupe(0)
'
'for x = 0 to (cptTot-1)
'
' ReDim Preserve AryRnd(UBound(AryRnd)+1)
'
' AryRnd(x) = arrFiles(x)
'
'next
'
'for x = 0 to (cptTot-1)
'
' ReDim Preserve arrDupe(UBound(arrDupe)+1)
'
' arrDupe(x) = arrFiles(x)
'
'next
'
'CC don't forget that arrays start at zero, the total number of files is the array length +1
'
'while z < cptTot
'
'intRnd = Int((cptTot * Rnd) + 1)
'bexists = false
'
'for x = 0 to cptTot
' If AryRnd(x) = intRnd then
' bexists = true
' exit for
' End if
'next
'
'if bexists = false then
' AryRnd(z) = intRnd
' arrFiles(z)=arrDupe(intRnd-1)
' z = z + 1
'end if
'Wend
'
'***********************************
'CC Randomizer Function End
'***********************************
Call createAndSavePlaylist(arrFiles, playlistPath)
Else
WshShell.Popup "The folder """& pathToScan &""" does not contain any of the filetypes defined in this script."& Chr(13) & Chr(13) &"To add support for new filetypes, edit the script and add the desired file extensions to the sExtToGetArr array."& Chr(13) & Chr(13), 0, sAppName, 64
End If
End Sub
'*********************************************************************************
Sub AddFiles(fold)
'-- process all mp3 files in the fold folder
Dim strExt, mpFiles, strName, foldName, foldPath, f, sulength, suname, leslash
foldPath = fold.Path
Set mpfiles = fold.Files
For each f in mpfiles
strName = f.Name
strExt = LCase(fso.GetExtensionName(strName))
'-- CC to solve issue with an output root directory having a backslash that's not part of the length of the foldPath string
If len(outputDir) = 3 Then
sulength = len(foldPath) - len(outputDir) + 1
Else
sulength = len(foldPath) - len(outputDir)
End If
'-- CC these variables enable outputting the string for the relative path beginning with the folder being scanned.
suname = len(foldPath) - (len(pathToScan))
If suname = 0 Then
leslash=""
Else
leslash="/"
End If
'-- leslash adds a "/" before folder names to show that it's a directory, this helps distinguish folders from files during the sorting, otherwise folders are sorted the same as files.
dim ExtIterate 'This integer used to iterate through file extension array.
For ExtIterate = 0 to UBound(sExtToGetArr)
If strExt = sExtToGetArr(ExtIterate) Then
'-- CC This is the string that outputs tags for individual files.
arrFiles(cptTot) = Replace((vbTab & ""& vbCrLf), "'","'")
ReDim Preserve arrFiles(UBound(arrFiles)+1)
cptTot = cptTot + 1 '-- global counter for processed files
End If
Next
Next
End Sub
'*********************************************************************************
Sub createAndSavePlaylist(arrFiles, playlistPath)
Dim txt, txtFile
'-- create XPSF file (Unicode)
If Not fso.FileExists(playlistPath) Then
Set txtFile = fso.CreateTextFile(playlistPath,true,true) 'Unicode!!
End If
Set txtFile = fso.GetFile(playlistPath)
Set txt = txtFile.OpenAsTextStream(ForWriting, -1)'0 for ASCII, -1 for Unicode
'-- write XML header info
txt.write("")
txt.write(vbCrLf)
txt.write("")
txt.write(vbCrLf)
txt.write("Your MP3 Playlist")
txt.write(vbCrLf)
txt.write("http://YourWebpageHere/")
txt.write(vbCrLf)
txt.write(vbCrLf)
txt.write("")
txt.write(vbCrLf)
txt.write(vbCrLf)
txt.write Join(arrFiles, vbCrLf)
txt.write(vbCrLf)
txt.write("")
txt.write(vbCrLf)
txt.write("")
txt.close
'***************************************************************
'Reencode file from Unicode to UTF-8
'***************************************************************
'CC - Added this section to re-encode file as UTF-8, there's probably a neater
' way, but this is a quick fix.
Dim objStream
Dim objStream2
'Create streams
Set objStream = CreateObject("ADODB.Stream")
set objStream2= CreateObject("ADODB.Stream")
'Initialize the streams
objStream.Open
objStream2.Open
'Set charactor encoding for output stream
objStream.Position = 0
objStream.Charset = "UTF-8"
objStream.Type = 2 'Sets file type as text data
'Read Unicode file into input text stream
objStream2.LoadFromFile txtFile
'Copy Unicode stream into UTF-8 stream
objStream2.CopyTo objStream
'Save the UTF-8 stream back into the original file
objStream.SaveToFile txtFile,2
objStream.Close
objStream2.Close
'***************************************************************
'End of UTF-8 Reencode
'***************************************************************
dim openplaylist
openplaylist = WshShell.Popup ("Finished. " & chr(13) & chr(13) & cptTot & " files have been playlisted in the following file:"& Chr(13)& Chr(13) & Replace(Replace(playlistPath,"\","/"),"//","/") & Chr(13) & Chr(13) & "**********************************************************************"& Chr(13) & "WARNING: IF YOU EDIT THIS FILE, MAKE SURE TO SAVE IT IN UTF-8 ENCODING"& Chr(13) & "**********************************************************************"& Chr(13) & Chr(13) & showTime(nTime)& Chr(13) & Chr(13) & Chr(13) & "Would you like to view your playlist?", 0,sAppName, 324)
If openplaylist = 6 Then
WshShell.Run "explorer.exe " & """" & Replace(playlistPath,"\\","\") & """"
End If
End Sub
'*********************************************************************************
Sub DoIt(fold)
'-- recursive scan
Dim sfold, sfoo
Call AddFiles(fold) 'process files in current folder
Set sfold = fold.subfolders
for each sfoo in sfold 'process files in subfolders
Call DoIt(sfoo)
Next
End Sub
'*********************************************************************************
Function showTime(nTime)
showTime = "Elapsed time : " & Round((Timer - nTime),2) &" seconds"
End Function
'*********************************************************************************
Sub QuickSort(vec,loBound,hiBound)
Dim pivot,loSwap,hiSwap,temp
'== This procedure is adapted from the algorithm given in:
'== Data Abstractions & Structures using C++ by
'== Mark Headington and David Riley, pg. 586
'== Quicksort is the fastest array sorting routine for
'== unordered arrays. Its big O is n log n
'== Two items to sort
if hiBound - loBound = 1 then
if vec(loBound) > vec(hiBound) then
temp=vec(loBound)
vec(loBound) = vec(hiBound)
vec(hiBound) = temp
End If
End If
'== Three or more items to sort
pivot = vec(int((loBound + hiBound) / 2))
vec(int((loBound + hiBound) / 2)) = vec(loBound)
vec(loBound) = pivot
loSwap = loBound + 1
hiSwap = hiBound
do
'== Find the right loSwap
while loSwap < hiSwap and vec(loSwap) <= pivot
loSwap = loSwap + 1
wend
'== Find the right hiSwap
while vec(hiSwap) > pivot
hiSwap = hiSwap - 1
wend
'== Swap values if loSwap is less then hiSwap
if loSwap < hiSwap then
temp = vec(loSwap)
vec(loSwap) = vec(hiSwap)
vec(hiSwap) = temp
End If
loop while loSwap < hiSwap
vec(loBound) = vec(hiSwap)
vec(hiSwap) = pivot
'== Recursively call function .. the beauty of Quicksort
'== 2 or more items in first section
if loBound < (hiSwap - 1) then Call QuickSort(vec,loBound,hiSwap-1)
'== 2 or more items in second section
if hiSwap + 1 < hibound then Call QuickSort(vec,hiSwap+1,hiBound)
End Sub 'QuickSort
'*********************************************************************************