' Creates an "index.html" and individual "html" web pages for a slide ' show of your pictures, text, and sound files (or any combination of ' those three). You MUST have your file names chosen so they'll be in the ' correct order. All related files MUST have the same base names and ' MUST have the following file extensions: ' JPG FULL SIZED CAMERA PICTURES ' JPEG WEB SIZED PICTURES ' TXT PLAIN TEXT NARRATIVE ABOUT THE PICTURE ' GIF THUMBNAIL SIZED PICTURE USED TO CREATE AN INDEX ' WAV, MP3, WMA AUDIO FILES OR NARRATIVE RELATING TO PICTURE ' All other file extensions present will be ignored. You can get ' a script which will create the GIF thumbnails and JPEG web-sized ' photos from here: ' http://www.ericphelps.com/scripting/samples/WebAndThumbnailCreator/index.html Option Explicit Main Sub Main() Dim strTextExtension, strTextPath, strTextFile Dim strPictureExtensions, strPictureExtension Dim strPicturePath, strBigPicturePath, strBigPictureFile, strBigPictureUrl, strBigPictureExtensions Dim strPictureUrlPath, strBigPictureUrlPath, strPictureUrl, strPictureFile Dim strSoundExtensions, strSoundExtension, strSoundPath, strSoundUrlPath, strSoundUrl, strSoundFile Dim strThumbnailPath, strThumbnailExtension, strThumbnailUrlPath, strThumbnailFile Dim strHtmSuffix, strHtmPath, strHtmFile, strHtmName Dim strTitle, strContent, strBaseName Dim strFirst, strLast, strHome, strPrevious, strNext Dim strDefault, strPrompt Dim blnZero, blnThumbnails Dim intCount Dim fs, fol, fils, fil, list() 'Register the FileSystem object If Not ((IsRegistered("Scripting.FileSystemObject")) And (IsRegistered("Wscript.Shell"))) Then If MsgBox ("You seem to have a bad or old installation of Microsoft Windows Scripting. I'd like to take you to a Microsoft web page where you can download Scripting Version 5.6. May I launch your browser to take you to the download page?", vbYesNo, "Update Needed") = vbYes Then Select Case OsVersion() Case 0 ws.Run "http://msdn.microsoft.com/downloads/list/webdev.asp?frame=true", 1, False Case 5 ws.Run "http://www.microsoft.com/downloads/details.aspx?FamilyId=C717D943-7E4B-4622-86EB-95A22B832CAA&displaylang=en", 1, False Case Else ws.Run "http://www.microsoft.com/downloads/details.aspx?FamilyId=0A8A18F6-249C-4A72-BFCF-FC6AF26DC390&displaylang=en", 1, False End Select End If MsgBox "After you (or your administrator) are done updating Scripting, you can re-run this program." Exit Sub End If Set fs = CreateObject("Scripting.FileSystemObject") 'Select the folder for processing strHtmPath = "" If WScript.Arguments.Count = 1 Then If fs.FolderExists(WScript.Arguments(0)) Then strHtmPath = WScript.Arguments(0) End If End If If strHtmPath = "" Then strHtmPath = BrowseForFolder("Slide Show Content Location:") If strHtmPath = "" Then Exit Sub strBigPicturePath = strHtmPath strTextPath = strHtmPath strPicturePath = strHtmPath strSoundPath = strHtmPath strThumbnailPath = strHtmPath strHtmSuffix = ".html" strTextExtension = ".txt" strPictureExtensions = ".jpeg" strBigPictureExtensions = ".jpg" strThumbnailExtension = ".gif" strSoundExtensions = ".wma, .wav, .mp3," strThumbnailUrlPath = "./" strPictureUrlPath = "./" strBigPictureUrlPath = "./" strSoundUrlPath = "./" strHome = "../" strFirst = "../" strLast = "../" '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 strTitle = InputBox("Enter the title for this presentation:", "Title", strTitle) '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 'Create the content Status "Creating files..." 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, strBigPictureExtensions, strBigPicturePath) If strBigPictureFile = "" Then strBigPictureUrl = "" Else strBigPictureUrl = strBigPictureUrlPath & strBigPictureFile 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 & "" & strTitle & "" strContent = strContent & vbCrLf & "" strContent = strContent & vbCrLf & "" strContent = strContent & vbCrLf & "" strContent = strContent & vbCrLf & "" strContent = strContent & vbCrLf & "" strContent = strContent & vbCrLf & "" strContent = strContent & vbCrLf & "
" & NavCode(strPrevious, strHome, strNext) & "" & PlayerCode(strSoundUrl) & "
" strContent = strContent & vbCrLf & ContentCode(strTextFile, strPictureUrl, strBigPictureUrl) strContent = strContent & vbCrLf & "" strContent = strContent & vbCrLf & "" String2File strContent, strHtmName Next 'Create the index page blnThumbnails = False Status "Creating index page..." strContent = "" strContent = strContent & vbCrLf & "" & strTitle & "" strContent = strContent & vbCrLf & "

" & strTitle & "

" strContent = strContent & vbCrLf & "Click a picture to begin the presentation at that point.
" strContent = strContent & vbCrLf & "


" For intCount = LBound(list) To UBound(list) strBaseName = fs.GetBaseName(list(intCount)) 'Get the file name of the thumbnail strThumbnailFile = FileNameIfExists(strBaseName, strThumbnailExtension, strThumbnailPath) If strThumbnailFile <> "" Then blnThumbnails = True strThumbnailFile = fs.BuildPath(strThumbnailUrlPath, strThumbnailFile) 'Get the URL for the web page strHtmName = strBaseName & strHtmSuffix 'Add the thumbnail to the index page strContent = strContent & vbCrLf & "" strContent = strContent & "  " End If Next If blnThumbnails Then strContent = strContent & vbCrLf & "" Else strContent = "" End If String2File strContent, fs.BuildPath(strHtmPath, "index" & strHtmSuffix) 'If the user is running Wscript, let them know it's done If Lcase(Right(Wscript.FullName, 12)) = "\wscript.exe" Then MsgBox "Files have been created for a web-based slide show. Your first page should be ""index" & strHtmSuffix & """." End If End Sub Function MatchesExtension(strFileName, strExtensions) Dim strExtension, blnMatchesExtension blnMatchesExtension = False For Each strExtension In Split(strExtensions, ",") If Left(strExtension, 1) <> "." Then strExtension = "." & strExtension If Lcase(Right(strFileName, Len(Trim(strExtension)))) = Lcase(Trim(strExtension)) Then blnMatchesExtension = True Exit For End If Next MatchesExtension = blnMatchesExtension End Function Function FileNameIfExists(strBaseName, strExtensions, strPath) Dim fs, fol, fils, fil, strExtension, intCount Set fs = CreateObject("Scripting.FileSystemObject") For Each strExtension In Split(strExtensions, ",") strExtension = Trim(strExtension) If Left(strExtension, 1) <> "." Then strExtension = "." & strExtension If fs.FileExists(fs.BuildPath(strPath, strBaseName & strExtension)) Then FileNameIfExists = fs.GetFile(fs.BuildPath(strPath, strBaseName & strExtension)).Name Exit Function End If Next FileNameIfExists = "" End Function Function BaseNameInArray(varArray, strFileName) Dim fs, strElement, strBase, blnInArray Set fs = CreateObject("Scripting.FileSystemObject") blnInArray = False strBase = Lcase(fs.GetBaseName(strFileName)) For Each strElement In varArray If Lcase(fs.GetBaseName(strElement)) = strBase Then blnInArray = True Exit For End If Next BaseNameInArray = blnInArray End Function 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 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 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 & "" strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & " " strBuffer = strBuffer & vbCrLf & " " 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 Function IsRegistered(strObjectName) 'Returns True if object can be created Dim obj On Error Resume Next Set obj = Nothing Set obj = CreateObject(strObjectName) If obj Is Nothing Then IsRegistered = False Else IsRegistered = True Set obj = Nothing End If End Function Function FileNameInThisDir(strFileName) 'As String 'Returns the complete path and file name to a file in 'the script directory. For example, "trans.log" might 'return "C:\Program Files\Scripts\Database\trans.log" 'if the script was in the "C:\Program Files\Scripts\Database" 'directory. Dim fs 'As Object Set fs = CreateObject("Scripting.FileSystemObject") FileNameInThisDir = fs.GetAbsolutePathName(fs.BuildPath(Wscript.ScriptFullName, "..\" & strFileName)) ''''''''''Clean up Set fs = Nothing End Function 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 OsVersion() 'Returns the base number for the OS (4 = Win9x, 5 = 2K/XP, 0 = unknown) Dim lngVersion, strVersion, objWMI, colSystems, objOS On Error Resume Next Err.Clear Set objWMI = GetObject("winmgmts:\\.\root\CIMV2") Set colSystems = objWMI.ExecQuery("SELECT * FROM Win32_OperatingSystem", "WQL", 48) For Each objOS In colSystems strVersion = objOS.Version Next If Err.Number <> 0 Then strVersion = "4" 'Assume lack of WMI means Windows 9X End If If InStr(strVersion, ".") > 1 Then strVersion = Left(strVersion, InStr(strVersion, ".") - 1) End If If IsNumeric(strVersion) Then lngVersion = Clng(strVersion) Else lngVersion = 0 End If OsVersion = lngVersion Set objWMI = Nothing End Function Sub Status(strMessage) If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then Wscript.Echo strMessage End If End Sub