Slide Show

'Reads JPG, GIF, BMP, etc files and creates a two-file framed HTM slideshow. 'Eric Phelps 2003 Released to Public Domain. Option Explicit Dim intCount, intPos, intEnd, intCommon Dim blnZero, blnSortAscending Dim strDirectory, strExtensions, strExtension, strSourcePath Dim strHtmData, strDestPath, strDestFile, strUrlPath Dim net, fs, fol, fils, fil, list() Set fs = CreateObject("Scripting.FileSystemObject") 'Ask what kind of file extensions strExtensions = InputBox("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 strSourcePath = fs.GetFolder(".").Path strSourcePath = BrowseForFolder("Picture file location: " & vbCrLf & "(Cancel=""" & strSourcePath & """)") If strSourcePath = "" Then strSourcePath = fs.GetFolder(".").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 where the output file will be strDestPath = BrowseForFolder("Put ""index.htm"" and ""select.htm"" files where: " & vbCrLf & "(Cancel=""" & strSourcePath & """)") If strDestPath = "" Then strDestPath = strSourcePath 'Ask what URL stuff needs to be added to the links strUrlPath = RelativePath(strDestPath, strSourcePath) If strUrlPath = "" Then strUrlPath = "./" strUrlPath = InputBox("What (if any) directory information should preceed each picture URL so that it can be located from the HTM files?", "URL Path", strUrlPath) If strUrlPath <> "" Then If Right(strUrlPath, 1) <> "/" Then strUrlPath = strUrlPath & "/" End If 'Create the index.htm file strDestFile = fs.BuildPath(strDestPath, "index.htm") strHtmData = "Slide Show" strHtmData = strHtmData & "" strHtmData = strHtmData & vbTab & "" strHtmData = strHtmData & vbTab & "" strHtmData = strHtmData & "" String2File strHtmData, strDestFile 'Create the select.htm file strHtmData = "" '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 HTM file strDestFile = fs.BuildPath(strDestPath, "select.htm") Status "Writing entries for select file..." For intCount = LBound(list) To UBound(list) Status list(intCount) strHtmData = strHtmData & vbCrLf & "

" strHtmData = strHtmData & list(intCount) strHtmData = strHtmData & "" Next strHtmData = strHtmData & vbCrLf & "" String2File strHtmData, strDestFile 'Announce our success to the world MsgBox """index.htm"" and ""select.htm"" have 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