'Reads image, audio, and text files and creates an HTM slideshow. 'Released to Public Domain by Eric Phelps 2005 'http://www.ericphelps.com Option Explicit Main Sub Main() Dim strTextExtension, strTextPath, strTextFile Dim strPictureExtensions, strPictureExtension Dim strPicturePath, strBigPicturePath, strBigPictureFile, strBigPictureUrl Dim strPictureUrlPath, strBigPictureUrlPath, strPictureUrl, strPictureFile Dim strSoundExtensions, strSoundExtension, strSoundPath, strSoundUrlPath, strSoundUrl, strSoundFile Dim strHtmSuffix, strHtmPath, strHtmFile, strHtmName Dim strTitle, strContent, strBaseName Dim strFirst, strLast, strHome, strPrevious, strNext Dim strDefault, strPrompt Dim blnZero, 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 extension strDefault = ".htm" If blnAcceptDefaults Then strHtmSuffix = strDefault Else strPrompt = "HTM web pages will be created for each slide. Enter the HTM web page suffix here:" strHtmSuffix = InputBox(strPrompt, "HTM Page Suffix", strDefault) strHtmSuffix = Trim(strHtmSuffix) If strHtmSuffix = "" Then strHtmSuffix = strDefault 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 strDefault = strHtmPath If blnAcceptDefaults Then strHtmPath = strDefault Else strPrompt = "Create content HTM web pages where: Cancel =" & vbCrLf & """" & strDefault & """" strHtmPath = BrowseForFolder(strPrompt) If strHtmPath = "" Then strHtmPath = strDefault End If 'Text source strDefault = strHtmPath If blnAcceptDefaults Then strTextPath = strDefault Else strPrompt = "Existing text files (if any) location: Cancel =" & vbCrLf & """" & strDefault & """" strTextPath = BrowseForFolder(strPrompt) If strTextPath = "" Then strTextPath = strDefault End If 'Text extensions strDefault = ".txt" If blnAcceptDefaults Then strTextExtension = strDefault Else strPrompt = "Existing text file extension:" strTextExtension = InputBox(strPrompt, "Text File Extension", strDefault) If Trim(strTextExtension) = "" Then strTextExtension = strDefault End If 'Picture extensions strDefault = ".png, .jpg, .jpeg, .gif, .bmp" If blnAcceptDefaults Then strPictureExtensions = strDefault Else strPrompt = "Existing picture file extensions (comma delimited string):" strPictureExtensions = InputBox(strPrompt, "Picture File Types", strDefault) If Trim(strPictureExtensions = "") Then strPictureExtensions = strDefault End If 'Picture source strDefault = strTextPath If blnAcceptDefaults Then strPicturePath = strDefault Else strPrompt = "Existing WEB-SIZE picture files (if any) location: Cancel =" & vbCrLf & """" & strDefault & """" strPicturePath = BrowseForFolder(strPrompt) If strPicturePath = "" Then strPicturePath = strDefault End If 'Picture URL strDefault = RelativePath(strHtmPath, strPicturePath) If strDefault = "" Then strDefault = "./" If blnAcceptDefaults Then strPictureUrlPath = strDefault Else strPrompt = "What (if any) directory information should preceed each WEB picture file so that it can be located from the HTM file?" strPictureUrlPath = InputBox(strPrompt, "Picture URL Path", strDefault) End If If strPictureUrlPath <> "" Then If Right(strPictureUrlPath, 1) <> "/" Then strPictureUrlPath = strPictureUrlPath & "/" End If 'Big picture source strDefault = strPicturePath 'Left(strTextPath, InStrRev(strTextPath, "\") - 1) If blnAcceptDefaults Then strBigPicturePath = strDefault Else strPrompt = "Existing FULL-SIZE picture files (if any) location: Cancel =" & vbCrLf & """" & strDefault & """" strBigPicturePath = BrowseForFolder(strPrompt) If strBigPicturePath = "" Then strBigPicturePath = strDefault End If 'Big Picture URL strDefault = RelativePath(strHtmPath, strBigPicturePath) If strDefault = "" Then strDefault = "./" If blnAcceptDefaults Then strBigPictureUrlPath = strDefault Else strPrompt = "What (if any) directory information should preceed each FULL SIZE picture file so that it can be located from the HTM file?" strBigPictureUrlPath = InputBox(strPrompt, "Picture URL Path", strDefault) End If If strBigPictureUrlPath <> "" Then If Right(strBigPictureUrlPath, 1) <> "/" Then strBigPictureUrlPath = strBigPictureUrlPath & "/" End If 'Sound source strDefault = strTextPath If blnAcceptDefaults Then strSoundPath = strDefault Else strPrompt = "Existing sound files (if any) location: Cancel =" & vbCrLf & """" & strDefault & """" strSoundPath = BrowseForFolder(strPrompt) If strSoundPath = "" Then strSoundPath = strDefault End If 'Sound extensions strDefault = ".wma, .asf, .wav, .mp3, .mid, .au" If blnAcceptDefaults Then strSoundExtensions = strDefault Else strPrompt = "Existing sound file extensions (comma delimited string):" strSoundExtensions = InputBox(strPrompt, "Sound File Types", strDefault) If Trim(strSoundExtensions = "") Then strSoundExtensions = strDefault End If 'Sound URL strDefault = RelativePath(strHtmPath, strSoundPath) If strDefault = "" Then strDefault = "./" If blnAcceptDefaults Then strSoundUrlPath = strDefault Else strPrompt = "What (if any) directory information should preceed each sound file so that it can be located from the HTM file?" strSoundUrlPath = InputBox(strPrompt, "Sound URL Path", strDefault) End If If strSoundUrlPath <> "" Then If Right(strSoundUrlPath, 1) <> "/" Then strSoundUrlPath = strSoundUrlPath & "/" End If 'Get the title If ((Len(fs.GetBaseName(strHtmPath)) > 2) And (Instr(fs.GetBaseName(strHtmPath), " ") = 0)) Then strDefault = Left(fs.GetBaseName(strHtmPath), 1) For intCount = 2 To Len(fs.GetBaseName(strHtmPath)) If InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZ", Mid(fs.GetBaseName(strHtmPath), intCount, 1)) <> 0 Then strDefault = strDefault & " " & Mid(fs.GetBaseName(strHtmPath), intCount, 1) Else strDefault = strDefault & Mid(fs.GetBaseName(strHtmPath), intCount, 1) End If Next Else strDefault = fs.GetBaseName(strHtmPath) End If If blnAcceptDefaults Then strTitle = strDefault Else strPrompt = "Enter the ""title"" of this presentation" strTitle = InputBox(strPrompt, "Title", strDefault) If Trim(strTitle) = "" Then strTitle = strDefault End If 'Create a "master" list of the defining file: picture, text, or audio (in that order) '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, ",") strPictureExtension = Trim(strPictureExtension) If Left(strPictureExtension, 1) <> "." Then strPictureExtension = "." & strPictureExtension If Lcase(Right(fil.Name, Len(Trim(strPictureExtension)))) = Lcase(Trim(strPictureExtension)) Then 'It's a picture. Add it to our list Status vbTab & fil.Name If Not blnZero Then ReDim Preserve list(UBound(list) + 1) blnZero = False list(UBound(list)) = fil.name Exit For End If Next Next 'Check text directory Set fol = fs.GetFolder(strTextPath) Set fils = fol.Files If Left(strTextExtension, 1) <> "." Then strTextExtension = "." & strTextExtension Status "Reading text file names..." For Each fil In fils If Lcase(Right(fil.Name, Len(Trim(strTextExtension)))) = Lcase(Trim(strTextExtension)) Then 'It's text. Status vbTab & fil.Name If Not BaseNameInArray(list, fil.Name) Then 'There's no picture by that name; add the text file to the list If Not blnZero Then ReDim Preserve list(UBound(list) + 1) blnZero = False list(UBound(list)) = fil.name End If End If Next 'Check sound directory Set fol = fs.GetFolder(strSoundPath) Set fils = fol.Files Status "Reading sound file names..." For Each fil In fils For Each strSoundExtension In Split(strSoundExtensions, ",") strSoundExtension = Trim(strSoundExtension) If Left(strSoundExtension, 1) <> "." Then strSoundExtension = "." & strSoundExtension If Lcase(Right(fil.Name, Len(Trim(strSoundExtension)))) = Lcase(Trim(strSoundExtension)) Then 'It's sound. Status vbTab & fil.Name If Not BaseNameInArray(list, fil.Name) Then 'There's no picture or text by that name; add the sound file to the list If Not blnZero Then ReDim Preserve list(UBound(list) + 1) blnZero = False list(UBound(list)) = fil.name Exit For End If End If Next Next 'Sort the list Status "Sorting names..." SortAscending list, "*", 0 'Get the wrap and home choices If blnAcceptDefaults Then strHome = "../" strFirst = strHome strLast = strHome Else Status "Getting HOME preference..." strPrompt = "During the presentation, if the user presses the ""Home"" button, what should happen?" strPrompt = strPrompt & vbCrLf & "1 - Go up one folder" strPrompt = strPrompt & vbCrLf & "2 - Go to the first slide" strPrompt = strPrompt & vbCrLf & "(Enter a number or a URL)" strDefault = "1" strHome = InputBox(strPrompt, "Home", strDefault) strHome = Trim(strHome) If strHome = "" Then strHome = strDefault Select Case Left(strHome, 1) Case "1" strHome = "../" Case "2" strHome = fs.GetBaseName(list(LBound(list))) & strHtmSuffix Case Else 'Do Nothing. Accept whatever the end-user entered. End Select Status "Getting FIRST preference..." strDefault = "1" strPrompt = "If the user is on the FIRST slide and presses the ""Back"" button, what should happen?" strPrompt = strPrompt & vbCrLf & "1 - Same thing as pressing ""Home""" strPrompt = strPrompt & vbCrLf & "2 - Stay at the first slide" strPrompt = strPrompt & vbCrLf & "3 - Wrap to the last slide" strFirst = InputBox(strPrompt, "Back", strDefault) strFirst = Trim(strFirst) If strFirst = "" Then strFirst = strDefault Select Case Left(strFirst, 1) Case "1" strFirst = strHome Case "2" strFirst = fs.GetBaseName(list(LBound(list))) & strHtmSuffix Case "3" strFirst = fs.GetBaseName(list(UBound(list))) & strHtmSuffix Case Else strFirst = strHome End Select Status "Getting LAST preference..." strDefault = "1" strPrompt = "If the user is on the LAST slide and presses the ""Next"" button, what should happen?" strPrompt = strPrompt & vbCrLf & "1 - Same thing as pressing ""Home""" strPrompt = strPrompt & vbCrLf & "2 - Stay at the last slide" strPrompt = strPrompt & vbCrLf & "3 - Wrap to the first slide" strLast = InputBox(strPrompt, "Next", strDefault) strLast = Trim(strLast) If strLast = "" Then strLast = strDefault Select Case Left(strLast, 1) Case "1" strLast = strHome Case "2" strLast = fs.GetBaseName(list(UBound(list))) & strHtmSuffix Case "3" strLast = fs.GetBaseName(list(LBound(list))) & strHtmSuffix Case Else strLast = strHome End Select End If 'Confirm If Not blnAcceptDefaults Then Status "Confirming permission to create files..." If MsgBox("Last question! Build the HTM files for a presentation?", vbOkCancel, "Proceed?") = vbCancel Then Exit Sub End If End If Status "Creating files..." 'Create the content For intCount = LBound(list) To UBound(list) strBaseName = fs.GetBaseName(list(intCount)) 'Get the file name of the text file strTextFile = FileNameIfExists(strBaseName, strTextExtension, strTextPath) If strTextFile <> "" Then strTextFile = fs.BuildPath(strTextPath, strTextFile) End If 'Get the URL for the picture strPictureFile = FileNameIfExists(strBaseName, strPictureExtensions, strPicturePath) If strPictureFile = "" Then strPictureUrl = "" Else strPictureUrl = strPictureUrlPath & strPictureFile End If 'Get the URL for the BIG picture strBigPictureFile = FileNameIfExists(strBaseName, strPictureExtensions, strBigPicturePath) If strBigPictureFile = "" Then strBigPictureUrl = "" Else strBigPictureUrl = strBigPictureUrlPath & strPictureFile End If 'Get the URL for the sound strSoundFile = FileNameIfExists(strBaseName, strSoundExtensions, strSoundPath) If strSoundFile = "" Then strSoundUrl = "" Else strSoundUrl = strSoundUrlPath & strSoundFile End If 'Get the name of the HTM file we'll be constructing strHtmName = fs.BuildPath(strHtmPath, strBaseName & strHtmSuffix) 'Get the Previous URL for navigation purposes If intCount = LBound(list) Then strPrevious = strFirst Else strPrevious = fs.GetBaseName(list(intCount - 1)) & strHtmSuffix End If 'Get the Next URL for navigation purposes If intCount = UBound(list) Then strNext = strLast Else strNext = fs.GetBaseName(list(intCount + 1)) & strHtmSuffix End If strContent = "" strContent = strContent & vbCrLf & "
" & NavCode(strPrevious, strHome, strNext) & " | " strContent = strContent & vbCrLf & "" & PlayerCode(strSoundUrl) & " | " strContent = strContent & 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 PlayerCode(strAudioUrl)
Dim strBuffer
If strAudioUrl = "" Then
strBuffer = " "
Else
strBuffer = ""
strBuffer = strBuffer & vbCrLf & ""
End If
PlayerCode = strBuffer
End Function
Function NavCode(strPrevious, strHome, strNext)
Dim strBuffer
strBuffer = ""
strBuffer = strBuffer & vbCrLf & "◄ "
strBuffer = strBuffer & vbCrLf & "☼ "
strBuffer = strBuffer & vbCrLf & "► "
strBuffer = strBuffer & ""
NavCode = strBuffer
End Function
Function ContentCode(strTextFilePath, strPictureUrl, strBigPictureUrl)
Dim strBuffer
strBuffer = ""
If strPictureUrl <> "" Then
strBuffer = strBuffer & vbCrLf
If strBigPictureUrl <> "" Then
strBuffer = strBuffer & ""
End If
strBuffer = strBuffer & " "" Then
strBuffer = strBuffer & "border=""0"">"
Else
strBuffer = strBuffer & ">"
End If
End If
If ((strPictureUrl <> "") And (strTextFilePath <> "")) Then
strBuffer = strBuffer & vbCrLf & "
"
'strBuffer = strBuffer & vbCrLf & "
"
'strBuffer = strBuffer & vbCrLf & ""
End If
If strTextFilePath <> "" Then
strBuffer = strBuffer & vbCrLf & Text2Html(File2String(strTextFilePath))
End If
ContentCode = strBuffer
End Function