'Creates a repeating ASX file for any media file.
'Eric Phelps 2003 Released to Public Domain.
Option Explicit
Dim strSourcePath, strAsxData, strAsxPath, strAsxName, strUrlPath, strAuthor
Dim net, fs, fol, fils, fil, list()
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Test input argument
	If Wscript.Arguments.Count <> 1 Then
		ShowHelp
		Wscript.Quit
	End If
	If Not fs.FileExists(Wscript.Arguments(0)) Then
		ShowHelp
		Wscript.Quit
	End If
	'Get destination location
	strSourcePath = fs.GetParentFolderName(WScript.Arguments(0))
	'Ask where the ASX file will be
	strAsxPath = BrowseForFolder("Create repeating ASX file where: " & vbCrLf & "(Cancel=""" & strSourcePath & """)")
	If strAsxPath = "" Then strAsxPath = strSourcePath
	'Ask what the ASX file should be named
	strAsxName = fs.GetBaseName(WScript.Arguments(0))
	If Lcase(Right(WScript.Arguments(0), 4)) = ".asx" Then
		strAsxName = strAsxName & ChrW(8734)
	End If
	strAsxName = strAsxName & ".asx"
	strAsxName = InputBox("Create the repeating ASX file with what name?", "ASX File Name", strAsxName)
	If Trim(strAsxName) = "" Then WScript.Quit
	'Ask what URL stuff needs to be added to the links
	strUrlPath = RelativePath(strAsxPath, strSourcePath)
	If strUrlPath = "" Then strUrlPath = "./"
	strUrlPath = InputBox("What (if any) directory information should preceed each source file so that it can be located from the ASX file?", "URL Path", strUrlPath)
	If strUrlPath <> "" Then
		If Right(strUrlPath, 1) <> "/" Then strUrlPath = strUrlPath & "/"
	End If
	'Convert the strAsxName into a fully-qualified path & file name
	strAsxName = fs.BuildPath(strAsxPath, strAsxName)
	'Write the ASX file header information
	strAsxData = "<ASX version = ""3.0"">"
	strAuthor = InputBox("Author", "Author", CreateObject("WScript.Network").UserName)
	strAsxData = strAsxData & vbCrLf & "<Author>" & strAuthor & "</Author>"
	strAsxData = strAsxData & vbCrLf & "<Title>" & InputBox("Title", "Title", fs.GetFileName(strAsxName)) & "</Title>"
	strAsxData = strAsxData & vbCrLf & "<Copyright>" & InputBox("Copyright Data", "Copyright", "©" & Year(Now) & " " & strAuthor & ". All Rights Reserved.") & "</Copyright>"
	'Write the lines of the ASX file
	Status "Creating body for ASX file..."
	strAsxData = strAsxData & vbCrLf & "<REPEAT>"
	strAsxData = strAsxData & vbCrLf & vbTab & "<ENTRY>"
	strAsxData = strAsxData & vbCrLf & vbTab & vbTab & "<REF href=""" 
	strAsxData = strAsxData & strUrlPath 
	strAsxData = strAsxData & fs.GetFileName(WScript.Arguments(0))
	strAsxData = strAsxData & """ />"
	strAsxData = strAsxData & vbCrLf & vbTab & "</ENTRY>"
	strAsxData = strAsxData & vbCrLf & "</REPEAT>"
	strAsxData = strAsxData & vbCrLf & "</ASX>"
	String2File strAsxData, strAsxName
	'Announce our success to the world
	MsgBox "File """ & strAsxName & """ has been created."
	
Sub ShowHelp()
	MsgBox "Drop any media file (a file capable of being played in Windows Media Player) on this script. An ASX file will be created which (when opened with Media Player) will repeatedly play your original media."
End Sub

Sub String2File(strData, strFileName)
'Writes a string to a file
Dim fs 'As Scripting.FileSystemObject
Dim ts 'As Scripting.TextStream
Dim lngChar, strBlock, intChar
Const ForWriting = 2
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set ts = fs.OpenTextFile(strFileName, ForWriting, True)
	Err.Clear
	On Error Resume Next
	ts.Write strData
	If Err.Number <> 0 Then
		'Must have hit one of the "problem characters" between 128 and 159
		For lngChar = 1 To Len(strData) Step 100
			Err.Clear
			ts.Write Mid(strData, lngChar, 100)
			If Err.Number <> 0 Then
				'This block of 100 must have the problem. Write them one-at-a-time
				strBlock = Mid(strData, lngChar, 100)
				For intChar = 1 To Len(strBlock)
					ts.Write Chr(255 And AscW(Mid(strBlock, intChar)))
				Next
			End If
		Next
	End If
	ts.Close
End Sub

Sub SortAscending(strArray, strSplitCharacter, intSortByElement)
Dim blnChanged 'As Boolean
Dim strBuffer 'As String
Dim intCounter 'As Integer
	blnChanged = True
	Do Until Not blnChanged
		blnChanged = False
		For intCounter = Lbound(strArray) + 1 to Ubound(strArray)
			If Split(strArray(intCounter -1), strSplitCharacter)(intSortByElement) > Split(strArray(intCounter), strSplitCharacter)(intSortByElement) Then
				blnChanged = True
				strBuffer = strArray(intCounter -1)
				strArray(intCounter -1) = strArray(intCounter)
				strArray(intCounter) = strBuffer
			End If
		Next
	Loop
End Sub

Sub SortDescending(strArray, strSplitCharacter, intSortByElement)
Dim blnChanged 'As Boolean
Dim strBuffer 'As String
Dim intCounter 'As Integer
	blnChanged = True
	Do Until Not blnChanged
		blnChanged = False
		For intCounter = Lbound(strArray) + 1 to Ubound(strArray)
			If Split(strArray(intCounter -1), strSplitCharacter)(intSortByElement) < Split(strArray(intCounter), strSplitCharacter)(intSortByElement) Then
				blnChanged = True
				strBuffer = strArray(intCounter -1)
				strArray(intCounter -1) = strArray(intCounter)
				strArray(intCounter) = strBuffer
			End If
		Next
	Loop
End Sub

Function FileNameLikeMine(strFileExtension) 'As String
'Returns a file name the same as the script name except
'for the file extension. 
Dim fs 'As Object
Dim strExtension 'As String
	Set fs = Wscript.CreateObject("Scripting.FileSystemObject")
	strExtension = strFileExtension
	If Len(strExtension) < 1 Then strExtension = "txt"
	If strExtension = "." Then strExtension = "txt"
	If Left(strExtension,1) = "." Then strExtension = Mid(strExtension, 2)
	FileNameLikeMine = Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & strExtension
	''''''''''Clean up
	Set fs = Nothing
End Function

Sub Status (strMessage)
	If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then 
		Wscript.Echo strMessage
	End If
End Sub

Function BrowseForFolder(strPrompt)
'Uses the "Shell.Application" (only present in Win98 and newer)
'to bring up a file/folder selection window. Falls back to an
'ugly input box under Win95.
'Shell32.ShellSpecialFolderConstants
Const ssfPERSONAL = 5 'My Documents
Const ssfDRIVES = 17 'My Computer
Const SFVVO_SHOWALLOBJECTS = 1
Const SFVVO_SHOWEXTENSIONS = 2 
	Dim sh, fol, fs, lngView, strPath
	Set sh = CreateObject("Shell.Application")
	If Instr(TypeName(sh), "Shell") = 0 Then
		BrowseForFolder = InputBox(strPrompt, "Select Folder", CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName))
		Exit Function
	End If
	Set fs = CreateObject("Scripting.FileSystemObject")
	lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS
	strPath = ""
	Set fol = sh.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
	Err.Clear
	On Error Resume Next
	strPath = fol.ParentFolder.ParseName(fol.Title).Path
	'An error occurs if the user selects a drive instead of a folder
	If Err.Number <> 0 Then
		BrowseForFolder = Left(Right(fol.Title, 3), 2) & "\"
	Else
		BrowseForFolder = strPath
	End If
End Function

Function BrowseForFile(strPrompt)
'Uses the "Shell.Application" (only present in Win98 and newer)
'to bring up a file/folder selection window. Falls back to an
'ugly input box under Win95.
'Shell32.ShellSpecialFolderConstants
Const ssfPERSONAL = 5 'My Documents
Const ssfDRIVES = 17 'My Computer
Const SFVVO_SHOWALLOBJECTS = 1 
Const SFVVO_SHOWEXTENSIONS = 2
Const SFVVO_SHOWFILES = 16384
	Dim sh, fol, fs, lngView, strPath
	Set sh = CreateObject("Shell.Application")
	If Instr(TypeName(sh), "Shell") = 0 Then
		BrowseForFile = InputBox(strPrompt, "Select Folder", CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName) & "\foo.vcf")
		Exit Function
	End If
	Set fs = CreateObject("Scripting.FileSystemObject")
	lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS Or SFVVO_SHOWFILES
	strPath = ""
	Set fol = sh.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
	On Error Resume Next
	strPath = fol.ParentFolder.ParseName(fol.Title).Path
	If strPath = "" Then
		strPath = fol.Title
		Set fol = fol.ParentFolder
		strPath = fs.BuildPath(fol.ParentFolder.ParseName(fol.Title).Path, strPath)
	End If
	BrowseForFile = strPath
End Function

Function RelativePath(strFrom, strTo)
'Returns a string containing a URL-relative path
'between the two folders or files. For example, if 
'strFrom was "C:\a\b\c\d\e" and strTo was "C:\a\b\x\y",
'then the result would be "../../../x/y/"
Dim intEnd, intCount, strRelativePath, strFromPath, strToPath
Dim fs
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Preserve input variables
	strFromPath = strFrom
	strToPath = strTo
	'Append a slash to folders (assuming we are doing local stuff)
	If Right(strFromPath, 1) <> "\" Then
		If fs.FolderExists(strFromPath) Then strFromPath = strFromPath & "\"
	End If
	If Right(strToPath, 1) <> "\" Then
		If fs.FolderExists(strToPath) Then strToPath = strToPath & "\"
	End If
	'To see how much the paths have in common, we see which is shortest
	If Len(strFromPath) > Len(strToPath) Then
		intEnd = Len(strToPath)
	Else
		intEnd = Len(strFromPath)
	End If
	'Find the common path
	For intCount = 1 To intEnd
		If Mid(strFromPath, intCount, 1) <> Mid(strToPath, intCount, 1) Then Exit For
	Next
	If intCount = 1 Then
		'The first character is different: They are on different drives? Give up!
		RelativePath = ""
		Exit Function
	End If
	'Replace the slashes
	strFromPath = Replace(strFromPath, "\", "/")
	strToPath = Replace(strToPath, "\", "/")
	'Back up the common counter to the nearest slash
	intCount = InStrRev(Left(strToPath, intCount), "/") + 1
	'Trim the paths
	strFromPath = Mid(strFromPath, intCount)
	strToPath = Mid(strToPath, intCount)
	'Start with the strToPath as the base for the relative path
	strRelativePath = Replace(strToPath, " ", "%20")
	'Walk up a level for every directory in strFromPath
	For intCount = 1 To Len(strFromPath)
		If Mid(strFromPath, intCount, 1) = "/" Then strRelativePath = "../" & strRelativePath
	Next
	RelativePath = strRelativePath
End Function