'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 = "
"
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