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