'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 = "" strAuthor = InputBox("Author", "Author", CreateObject("WScript.Network").UserName) strAsxData = strAsxData & vbCrLf & "" & strAuthor & "" strAsxData = strAsxData & vbCrLf & "" & InputBox("Title", "Title", fs.GetFileName(strAsxName)) & "" strAsxData = strAsxData & vbCrLf & "" & InputBox("Copyright Data", "Copyright", "©" & Year(Now) & " " & strAuthor & ". All Rights Reserved.") & "" '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 & "" For intCount = LBound(list) To UBound(list) Status list(intCount) 'ASX strAsxData = strAsxData & vbCrLf If blnRepeat Then strAsxData = strAsxData & vbTab strAsxData = strAsxData & "" strAsxData = strAsxData & "" strAsxData = strAsxData & "" & list(intCount) strAsxData = strAsxData & "" Next If blnRepeat Then strAsxData = strAsxData & vbCrLf & "" 'Close the ASX tag; all done writing the ASX file strAsxData = strAsxData & vbCrLf & "" 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