PC-HELP.CZ

Kód: Vybrat vše

'*********************************************************************************
'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
'description: recursive m3u playlist generator :
' create ONE single playlist for ALL mp3 files
' found in the selected path, the generated playlist
' is saved in the scanned folder and uses absolute paths
'usage : create shortcut to this file in the "SendTo" folder or drag-drop folder on it

'*********************************************************************************
'MODIFIED BY: charlie craig, craigcharlieATSYMBOLhotmail.com
'mod. date : 13.04.2006
'mod. reason : Recoded this to generate XPSF playlists;
' Just change the "My MP3 Playlist" string and the
' "http://www.MyHomePage.com" string to have your personal info
' automatically added to the generated output.
'*********************************************************************************


'***********************************
'BEGIN
'***********************************
Option Explicit
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, WshShell, cptTot, objArgs, arrFiles(), sExtToGet
Dim driveLetter, pathToScan, fold, nTime, sAppName
Set fso = CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")
sAppName = "Mp3Playlister - 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

'end CC

'-- lowercase file extension to search for
sExtToGet = "mp3"
'-- playlist file extension
Const sPlaylistExt = "xml"

Set objArgs = WScript.Arguments
if ( objArgs.Count = 0 ) then
WshShell.Popup "You must specify a directory. ", 7, sAppName, 48
WScript.Quit
end if
pathToScan = objArgs(0)

if ucase(left(pathToScan, len(outputDir))) <> ucase(outputDir) then
WshShell.Popup "You may only scan directories that are found within the same directory as this script (i.e., """ & outputDir & """", 11, 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 playlistPath = fold.path &"\"& fold.Name & "." & sPlaylistExt

'-- recurse folder
Call DoIt(fold)
Else
WshShell.Popup "Folder """& pathToScan &""" does not exist. ", 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)
Call createAndSavePlaylist(arrFiles, playlistPath)
End If

WshShell.Popup "Finished. " & chr(13) & chr(13) & cptTot & _
" files have been playlisted in the following file:"& Chr(13)& Chr(13) & _
Replace(playlistPath,"\","/") & Chr(13) & Chr(13) & showTime(nTime) _
, 0, sAppName, 64
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.

If strExt = sExtToGet Then

'-- CC this is the string that outputs file names
arrFiles(cptTot) = vbTab & "<track>"& vbCrLf& vbTab & vbTab & vbTab & "<annotation>"& Replace(Right(foldPath, suname),"\","/") & leslash & UCase(Left(strName, 1)) & Mid(strName,2,Len(strName))&"</annotation>" & vbCrLf & vbTab & vbTab & vbTab & "<location>"& "." & Replace(Right(foldPath, sulength),"\","/") &"/"& UCase(Left(strName, 1)) & Mid(strName,2,Len(strName))&"</location>" & vbCrLf & vbTab & vbTab & vbTab &"<info>"& "http://www.google.com/search?hl=en"&Chr(38)&"q="& Replace(Left(strName,(Len(strName)-4))," ", "+")&"</info>"& vbCrLf & vbTab &"</track>"& vbCrLf


ReDim Preserve arrFiles(UBound(arrFiles)+1)
cptTot = cptTot + 1 '-- global counter for processed files
End If
Next

End Sub
'*********************************************************************************

Sub createAndSavePlaylist(arrFiles, playlistPath)
Dim txt, txtFile

'-- create XPSF file (ASCII)
If Not fso.FileExists(playlistPath) Then
Set txtFile = fso.CreateTextFile(playlistPath,true,false) 'ASCII !!
End If
Set txtFile = fso.GetFile(playlistPath)
Set txt = txtFile.OpenAsTextStream(ForWriting, -1) 'ForWriting , 0 for ASCII (-1 for Unicode)
'-- write XML header info
txt.write("<?xml version="&Chr(34)&"1.0"&Chr(34)&" encoding="&Chr(34)&"UTF-8"&Chr(34)&" ?>")
txt.write(vbCrLf)
txt.write("<playlist version="&Chr(34)&"1"&Chr(34)&" xmlns="&Chr(34)&"http://xspf.org/ns/0/"&Chr(34)&">")
txt.write(vbCrLf)
txt.write("<title>Your MP3 Playlist</title>")
txt.write(vbCrLf)
txt.write("<info>http://YourWebsiteHere </info>")
txt.write(vbCrLf)
txt.write(vbCrLf)
txt.write("<trackList>")
txt.write(vbCrLf)
txt.write(vbCrLf)
txt.write Join(arrFiles, vbCrLf)
txt.write(vbCrLf)
txt.write("</trackList>")
txt.write(vbCrLf)
txt.write("</playlist>")

txt.close
Set txtFile = nothing
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
'*********************************************************************************