'Reads JPG, GIF, BMP, etc files and creates an ASX file.
'Eric Phelps 2003 Released to Public Domain.
Option Explicit
Dim lngDuration, intCount, intPos, intEnd, intCommon
Dim blnZero, blnSortAscending, blnRepeat
Dim strDirectory, strExtensions, strExtension, strSourcePath, str
Dim strAsxData, strAsxPath, strAsxName, strUrlPath, strAuthor
Dim net, fs, fol, fils, fil, list()
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Ask what kind of file extensions
	strExtensions = InputBox("Existing picture file extensions (comma delimited string):", "File Types", "jpg, jpeg, gif, bmp, png")
	If Trim(strExtensions = "") Then WScript.Quit
	'Ask where the JPG files are
	If WScript.Arguments.Count = 1 Then
		strSourcePath = WScript.Arguments(0)
		If fs.FileExists(strSourcePath) Then
			strSourcePath = fs.GetParentFolderName(strSourcePath)
		End If
		If Not fs.FolderExists(strSourcePath) Then
			strSourcePath = fs.GetFolder(".").Path
		End If
	Else
		strSourcePath = fs.GetFolder(".").Path
	End If
	Set fol = fs.GetFolder(strSourcePath)
	strSourcePath = BrowseForFolder("Existing pictures file location: Cancel =" & vbCrLf & """" & strSourcePath & """")
	If strSourcePath = "" Then strSourcePath = fol.Path
	'Ask how to sort the JPG files
	If MsgBox("The files you've selected will be displayed in ascending sorted name order. Select ""Yes"" if this is okay. Select ""No"" if you prefer descending order.", vbYesNo, "Sort Ascending") = vbYes Then
		blnSortAscending = True
	Else
		blnSortAscending = False
	End If
	'Ask how long to display each picture
	lngDuration = InputBox("How many seconds should each picture be displayed?", "Duration", "5")
	If lngDuration = "" Then WScript.Quit
	If Not IsNumeric(lngDuration) Then lngDuration = 5
	lngDuration = CLng(lngDuration)
	blnRepeat = MsgBox("Repeat?" & vbCrLf & "(Select ""Yes"" to repeat, or ""No"" to stop on the last picture)", vbYesNo, "Repeat") = vbYes
	'Ask where the ASX file will be
	strAsxPath = BrowseForFolder("Create ASX file where: Cancel =" & vbCrLf & """" & strSourcePath & """")
	If strAsxPath = "" Then strAsxPath = strSourcePath
	'Ask what the ASX file should be named
	strAsxName = Mid(strSourcePath, InStrRev(strSourcePath, "\") + 1)
	strAsxName = InputBox("Create the ASX file with what name?", "ASX File Name", strAsxName & ".asx")
	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>"
	'Get a reference to the collection of files in the source directory
	Set fol = fs.GetFolder(strSourcePath)
	Set fils = fol.Files
	ReDim list(0)
	blnZero = True
	Status "Reading file names..."
	'Check every file in the source directory
	For Each fil In fils
		For Each strExtension In Split(strExtensions, ",")
			If Lcase(Right(fil.Name, Len(Trim(strExtension))))  = Lcase(Trim(strExtension)) Then
				'If the file has one of the desired extensions, add it to our list
				If Not blnZero Then ReDim Preserve list(UBound(list) + 1)
				blnZero = False
				list(UBound(list)) = fil.name
				Exit For
			End If
		Next
	Next
	'Sort the list
	Status "Sorting names..."
	If blnSortAscending Then
		SortAscending list, "*", 0
	Else
		SortDescending list, "*", 0
	End If
	'Now read the list and write individual lines of the ASX file
	Status "Creating bodies for ASX file..."
	If blnRepeat Then strAsxData = strAsxData & vbCrLf & "<Repeat>"
	For intCount = LBound(list) To UBound(list)
		Status list(intCount)
		'ASX
		strAsxData = strAsxData & vbCrLf
		If blnRepeat Then strAsxData = strAsxData & vbTab
		strAsxData = strAsxData & "<Entry>"
		strAsxData = strAsxData & "<Duration Value="""
		strAsxData = strAsxData & "00:" & Right("00" & Cstr(lngDuration \ 60), 2)
		strAsxData = strAsxData & ":" & Right("00" & Cstr(lngDuration Mod 60), 2)
		strAsxData = strAsxData & """ />"
		strAsxData = strAsxData & "<ref href="""
		strAsxData = strAsxData & strUrlPath
		strAsxData = strAsxData & list(intCount)
		strAsxData = strAsxData & """ /><Title>" & list(intCount)
		strAsxData = strAsxData & "</Title></Entry>"
	Next
	If blnRepeat Then strAsxData = strAsxData & vbCrLf & "</Repeat>"
	'Close the ASX tag; all done writing the ASX file
	strAsxData = strAsxData & vbCrLf & "</ASX>"
	String2File strAsxData, strAsxName
	'Announce our success to the world
	MsgBox "File """ & strAsxName & """ has been created."
	

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