'Reads audio and picture files and creates an HTM slideshow. 'Released to Public Domain by Eric Phelps 2004 Option Explicit Main Sub Main() Dim strSoundExtensions, strSoundExtension, strSoundPath, strSoundUrlPath, strSoundFile Dim strPictureExtensions, strPictureExtension, strPicturePath, strPictureUrlPath, strPictureFile Dim strHtmNames, strHtmFile, strHtmPath Dim strTitle, strTemp Dim blnZero, blnReserved, blnAcceptDefaults Dim intCount Dim fs, fol, fils, fil, list() Set fs = CreateObject("Scripting.FileSystemObject") 'If we got a good argument, see if user will accept all defaults. blnAcceptDefaults = False If WScript.Arguments.Count = 1 Then strHtmPath = WScript.Arguments(0) If fs.FileExists(strHtmPath) Then strHtmPath = fs.GetParentFolderName(strHtmPath) End If If fs.FolderExists(strHtmPath) Then blnAcceptDefaults = MsgBox("Accept defaults? If you've used this script before and you know the automatic choices will work for you, choose ""Yes"". Otherwise choose ""No"" to be given the opportunity to make custom choices.", vbYesNo, "Accept Defaults") = vbYes End If End If 'HTM destination If WScript.Arguments.Count = 1 Then strHtmPath = WScript.Arguments(0) If fs.FileExists(strHtmPath) Then strHtmPath = fs.GetParentFolderName(strHtmPath) End If If Not fs.FolderExists(strHtmPath) Then strHtmPath = fs.GetFolder(".").Path End If Else strHtmPath = fs.GetFolder(".").Path End If If Not blnAcceptDefaults Then strTemp = strHtmPath strHtmPath = BrowseForFolder("Create HTM files where: Cancel =" & vbCrLf & """" & strHtmPath & """") If strHtmPath = "" Then strHtmPath = strTemp End If 'HTM names strHtmNames = "index.htm, navigate.htm, intro.htm, blank.htm" If Not blnAcceptDefaults Then strHtmNames = InputBox("An ""index"" (main) web page, a ""navigation"" (buttons and links) web page, an ""introductory"" (instructions) web page, and a ""blank"" (empty) web page will be created. Enter the comma-separated names for these files:", "HTM File Names", strHtmNames) strHtmNames = Trim(strHtmNames) If strHtmNames = "" Then Exit Sub End If 'Sound source strSoundPath = strHtmPath If Not blnAcceptDefaults Then strSoundPath = BrowseForFolder("Existing sound files location: Cancel =" & vbCrLf & """" & strSoundPath & """") If strSoundPath = "" Then strSoundPath = strHtmPath End If 'Sound extensions strSoundExtensions = ".wav, .mp3, .wma, .asf" If Not blnAcceptDefaults Then strSoundExtensions = InputBox("Sound file extensions (comma delimited string):", "Sound File Types", strSoundExtensions) If Trim(strSoundExtensions = "") Then Exit Sub End If 'Sound URL strSoundUrlPath = RelativePath(strHtmPath, strSoundPath) If strSoundUrlPath = "" Then strSoundUrlPath = "./" If Not blnAcceptDefaults Then strSoundUrlPath = InputBox("What (if any) directory information should preceed each sound file so that it can be located from the HTM file?", "Sound URL Path", strSoundUrlPath) End If If strSoundUrlPath <> "" Then If Right(strSoundUrlPath, 1) <> "/" Then strSoundUrlPath = strSoundUrlPath & "/" End If 'Picture source strPicturePath = strSoundPath If Not blnAcceptDefaults Then strPicturePath = BrowseForFolder("Existing picture files location: Cancel =" & vbCrLf & """" & strPicturePath & """") If strPicturePath = "" Then strPicturePath = strSoundPath End If 'Picture extensions strPictureExtensions = ".htm, .html, .png, .jpg, .jpeg, .gif, .bmp" If Not blnAcceptDefaults Then strPictureExtensions = InputBox("Picture file extensions (comma delimited string):", "Picture File Types", strPictureExtensions) If Trim(strPictureExtensions = "") Then Exit Sub End If 'Picture URL strPictureUrlPath = RelativePath(strHtmPath, strPicturePath) If strPictureUrlPath = "" Then strPictureUrlPath = "./" If Not blnAcceptDefaults Then strPictureUrlPath = InputBox("What (if any) directory information should preceed each picture file so that it can be located from the HTM file?", "Picture URL Path", strPictureUrlPath) End If If strPictureUrlPath <> "" Then If Right(strPictureUrlPath, 1) <> "/" Then strPictureUrlPath = strPictureUrlPath & "/" End If 'Get the title If ((Len(fs.GetBaseName(strHtmPath)) > 2) And (Instr(fs.GetBaseName(strHtmPath), " ") = 0)) Then strTitle = Left(fs.GetBaseName(strHtmPath), 1) For intCount = 2 To Len(fs.GetBaseName(strHtmPath)) If InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZ", Mid(fs.GetBaseName(strHtmPath), intCount, 1)) <> 0 Then strTitle = strTitle & " " & Mid(fs.GetBaseName(strHtmPath), intCount, 1) Else strTitle = strTitle & Mid(fs.GetBaseName(strHtmPath), intCount, 1) End If Next Else strTitle = fs.GetBaseName(strHtmPath) End If If Not blnAcceptDefaults Then strTitle = InputBox("Enter the ""title"" of this presentation", "Title", strTitle) End If 'Confirm If Not blnAcceptDefaults Then If MsgBox("Last question! Build the HTM files for a presentation?", vbOkCancel, "Proceed?") = vbCancel Then Exit Sub End If End If 'Check all files in the sound directory Set fol = fs.GetFolder(strSoundPath) Set fils = fol.Files ReDim list(0) blnZero = True Status "Reading sound file names..." For Each fil In fils For Each strSoundExtension In Split(strSoundExtensions, ",") strSoundExtension = Trim(strSoundExtension) If Lcase(Right(fil.Name, Len(Trim(strSoundExtension)))) = Lcase(Trim(strSoundExtension)) 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..." SortAscending list, "*", 0 'Check the sound list for first matching picture file For intCount = LBound(list) To UBound(list) strSoundFile = list(intCount) strPictureFile = fs.GetBaseName(strSoundFile) strPictureFile = fs.BuildPath(strPicturePath, strPictureFile) list(intCount) = "," & strSoundUrlPath & list(intCount) For Each strPictureExtension In Split(strPictureExtensions, ",") strPictureExtension = Trim(strPictureExtension) If fs.FileExists(strPictureFile & Trim(strPictureExtension)) Then blnReserved = False For Each strHtmFile In Split(strHtmNames) strHtmFile = Trim(LCase(strHtmFile)) If strHtmFile = Lcase(fs.GetFileName(strPictureFile & Trim(strPictureExtension))) Then blnReserved = True End If Next If Not blnReserved Then list(intCount) = strPictureUrlPath & fs.GetFileName(strPictureFile & Trim(strPictureExtension)) & list(intCount) Exit For End If End If Next Next 'Write the Index file strHtmFile = Split(strHtmNames, ",")(0) strHtmFile = Trim(strHtmFile) strHtmFile = fs.BuildPath(strHtmPath, strHtmFile) Status "Creating """ & strHtmFile & """" String2File IndexFile(strTitle, Trim(Split(strHtmNames, ",")(1)), Trim(Split(strHtmNames, ",")(2)), Trim(Split(strHtmNames, ",")(3))), strHtmFile 'Write the Navigate file strHtmFile = Split(strHtmNames, ",")(1) strHtmFile = Trim(strHtmFile) strHtmFile = fs.BuildPath(strHtmPath, strHtmFile) Status "Creating """ & strHtmFile & """" String2File NavigateBegin(), strHtmFile For intCount = LBound(list) To UBound(list) AppendToFile strHtmFile, NavigateEntry(list(intCount)) Next AppendToFile strHtmFile, vbCrLf & NavigateEnd() 'Write the Intro file strHtmFile = Split(strHtmNames, ",")(2) strHtmFile = Trim(strHtmFile) strHtmFile = fs.BuildPath(strHtmPath, strHtmFile) Status "Creating """ & strHtmFile & """" String2File IntroFile(strTitle), strHtmFile 'Write the Blank file strHtmFile = Split(strHtmNames, ",")(3) strHtmFile = Trim(strHtmFile) strHtmFile = fs.BuildPath(strHtmPath, strHtmFile) Status "Creating """ & strHtmFile & """" String2File BlankFile(), strHtmFile MsgBox "Files have been created." End Sub Sub AppendToFile(strFile, strText) Dim fs 'As Scripting.FileSystemObject Dim ts 'As Scripting.TextStream Const ForAppending = 8 Set fs = CreateObject("Scripting.FileSystemObject") Set ts = fs.OpenTextFile(strFile, ForAppending, True) ts.Write strText 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 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 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 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 Function BlankFile() Dim strBuffer strBuffer = "" BlankFile = strBuffer End Function Function IndexFile(strTitle, strNavigateFile, strIntroFile, strBlankFile) Dim strBuffer strBuffer = "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" & strTitle & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" IndexFile = strBuffer End Function Function IntroFile(strTitle) Dim strBuffer strBuffer = "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" & strTitle & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "

" & strTitle & "

" strBuffer = strBuffer & vbCrLf & "

Press the ""Start"" button to begin the presentation. " strBuffer = strBuffer & vbCrLf & "If you are using Internet Explorer, the presentation will " strBuffer = strBuffer & vbCrLf & "advance automatically. For all other browsers (or if you disable " strBuffer = strBuffer & vbCrLf & "the IE automatic advance), use the "">"" and ""<"" buttons " strBuffer = strBuffer & vbCrLf & "to control the presentation.

" strBuffer = strBuffer & vbCrLf & "

You may jump directly to a desired slide in the presentation by " strBuffer = strBuffer & vbCrLf & "clicking one of the numbered slide links." strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" IntroFile = strBuffer End Function Function NavigateBegin() Dim strBuffer strBuffer = "" strBuffer = strBuffer & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "

" strBuffer = strBuffer & vbCrLf & "
" strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & "

" strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & "

" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "

" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "
" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" NavigateEnd = strBuffer End Function