'Reads audio and picture files and creates an HTM slideshow. 'Creates a simple "index" file which allows manual selection 'and advancement between slides. Also creates a basic web 'page for every image file that has a matching text file. 'Released to Public Domain by Eric Phelps 2004 Option Explicit Main Sub Main() Dim strTextExtension, strTextPath, strTextFile Dim strPictureExtensions, strPictureExtension, strPicturePath, strPictureUrlPath, strPictureFile Dim strHtmSuffix, strHtmPath, strHtmFile, strHtmNames, strHtmName Dim strTitle Dim blnZero, blnTextLinks, 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 names strHtmNames = "index.htm, nav.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 'Text or Numeric Links? blnTextLinks = True If Not blnAcceptDefaults Then blnTextLinks = MsgBox("The navigation page will contain individual links for all content. These links can be sequential page numbers or text links based on the file name. Should I create text links?", vbYesNo, "Link Style") = vbYes End If strHtmSuffix = ".htm" If Not blnAcceptDefaults Then strHtmSuffix = InputBox("Content web pages will be created for each picture. Enter the content page suffix here:", "Content Suffix", ".htm") strHtmSuffix = Trim(strHtmSuffix) If strHtmSuffix = "" Then Exit Sub 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 strTextPath = strHtmPath If Not blnAcceptDefaults Then strHtmPath = BrowseForFolder("Create new HTM files where: Cancel =" & vbCrLf & """" & strHtmPath & """") If strHtmPath = "" Then strHtmPath = strTextPath End If 'Picture source strPicturePath = strHtmPath If Not blnAcceptDefaults Then strPicturePath = BrowseForFolder("Existing picture files location: Cancel =" & vbCrLf & """" & strPicturePath & """") If strPicturePath = "" Then strPicturePath = strHtmPath End If 'Picture extensions strPictureExtensions = ".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 'Text source strTextPath = strPicturePath If Not blnAcceptDefaults Then strTextPath = BrowseForFolder("Existing text files (if any) location: Cancel =" & vbCrLf & """" & strTextPath & """") If strTextPath = "" Then strTextPath = strPicturePath End If 'Text extensions strTextExtension = ".txt" If Not blnAcceptDefaults Then strTextExtension = InputBox("Text files extension:", "Text File Extension", ".txt") If Trim(strTextExtension = "") Then Exit Sub 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 picture directory Set fol = fs.GetFolder(strPicturePath) Set fils = fol.Files ReDim list(0) blnZero = True Status "Reading picture file names..." For Each fil In fils For Each strPictureExtension In Split(strPictureExtensions, ",") If Lcase(Right(fil.Name, Len(Trim(strPictureExtension)))) = Lcase(Trim(strPictureExtension)) 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 list for matching text file For intCount = LBound(list) To UBound(list) strPictureFile = list(intCount) strTextFile = fs.GetBaseName(strPictureFile) strTextFile = fs.BuildPath(strTextPath, strTextFile) strTextFile = strTextFile & strTextExtension 'If there's a text file, create an HTM file If fs.FileExists(strTextFile) Then 'Get the raw HTM file name strHtmName = list(intCount) strHtmName = fs.GetBaseName(strHtmName) strHtmName = strHtmName & strHtmSuffix 'Replace array image name with HTM name list(intCount) = strHtmName 'Build the actual HTM file strHtmFile = fs.BuildPath(strHtmPath, strHtmName) String2File ContentFile(strTextFile, strPictureUrlPath & strPictureFile, Trim(Split(strHtmNames, ",")(0))), strHtmFile Else list(intCount) = strPictureUrlPath & strPictureFile End If Next 'Write the Index file strHtmFile = Trim(Split(strHtmNames, ",")(0)) 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(blnTextLinks), 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 File2String(strFile) 'As String Dim fs 'As Scripting.FileSystemObject Dim ts 'As Scripting.TextStream Const ForReading = 1 Set fs = CreateObject("Scripting.FileSystemObject") If fs.FileExists(strFile) Then Set ts = fs.OpenTextFile(strFile, ForReading, True) If ts.AtEndOfStream Then File2String ="" Else File2String = ts.ReadAll End If ts.Close Else File2String = "" End If End Function 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 = 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 End Function Function Text2Html(strRawData) 'As String 'Makes raw text safe to display on a web page Dim strText2Html 'As String strText2Html = strRawData strText2Html = Replace(strText2Html, "<", "<") strText2Html = Replace(strText2Html, ">", ">") strText2Html = Replace(strText2Html, "&", "&") strText2Html = Replace(strText2Html, vbCrLf & vbCrLf, vbCrLf & "

" & vbCrLf) strText2Html = Replace(strText2Html, vbCr & vbCr, vbCrLf & "

" & vbCrLf) strText2Html = Replace(strText2Html, vbLf & vbLf, vbCrLf & "

" & vbCrLf) strText2Html = Replace(strText2Html, vbTab, "    ") strText2Html = Replace(strText2Html, " ", "  ") Text2Html = strText2Html 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 ContentFile(strTextFilePath, strPictureUrl, strIndexUrl) Dim strBuffer strBuffer = "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "
" 'strBuffer = strBuffer & vbCrLf & "
" 'strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & Text2Html(File2String(strTextFilePath)) strBuffer = strBuffer & vbCrLf & "" ContentFile = strBuffer 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 or one of the individual page " strBuffer = strBuffer & vbCrLf & "links to begin. Use the "">"" and ""<"" buttons " strBuffer = strBuffer & vbCrLf & "to control the presentation.

" strBuffer = strBuffer & vbCrLf & "" strBuffer = strBuffer & vbCrLf & "" IntroFile = strBuffer End Function Function NavigateBegin(blnTextLinks) Dim strBuffer Dim strTextLinks If blnTextLinks Then strTextLinks = "true" Else strTextLinks = "false" End If 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 & "" NavigateEnd = strBuffer End Function