" & fil.Name & "

'Reads AVI, MPG, or MOV video files and creates an HTM file for each one. 'The HTM file displays the video with no controls. 'Uses conditional comment browser detection method: 'http://msdn.microsoft.com/workshop/author/dhtml/overview/ccomment_ovw.asp 'For IE browser, displays video using the "img dynsrc" tag. See: 'http://msdn.microsoft.com/workshop/author/dhtml/reference/properties/dynsrc.asp 'Eric Phelps 2003 Released to Public Domain. Option Explicit Dim strDirectory, strExtensions, strExtension, strHtmName, strUrlName Dim strSourcePath, strHtmPath, strHtmAppend, strUrlPath Dim net, fs, fol, fils, fil, list() Set fs = CreateObject("Scripting.FileSystemObject") 'Ask what kind of file extensions strExtensions = InputBox("Source file extensions (comma delimited string):", "File Types", "avi, mpg, mov") If Trim(strExtensions = "") Then WScript.Quit 'Ask where the source files are strSourcePath = fs.GetFolder(".").Path strSourcePath = BrowseForFolder("Source files location: " & vbCrLf & "(Cancel=""" & strSourcePath & """)") If strSourcePath = "" Then strSourcePath = fs.GetFolder(".").Path 'Ask where the HTM file will be strHtmPath = BrowseForFolder("Create HTM files where: " & vbCrLf & "(Cancel=""" & strSourcePath & """)") If strHtmPath = "" Then strHtmPath = strSourcePath 'Ask what the HTM file should be named strHtmAppend = InputBox("HTM files will have the same base name as source files, but with an htm extension. If you enter anything here, it will REPLACE the dot and everything to the end.", "HTM File Name", ".html") strHtmAppend = Trim(strHtmAppend) If strHtmAppend = "" Then strHtmAppend = ".htm" 'Ask what URL stuff needs to be added to the links strUrlPath = RelativePath(strHtmPath, strSourcePath) If strUrlPath = "" Then strUrlPath = "./" strUrlPath = InputBox("What (if any) directory information should preceed each source file so that it can be located from the HTM file?", "URL Path", strUrlPath) If strUrlPath <> "" Then If Right(strUrlPath, 1) <> "/" Then strUrlPath = strUrlPath & "/" End If 'Get a reference to the collection of files in the source directory Set fol = fs.GetFolder(strSourcePath) Set fils = fol.Files Status "Creating bodies for HTM files..." '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 strHtmName = fs.BuildPath(strHtmPath, fs.GetBaseName(fil.Path) & strHtmAppend) strUrlName = strUrlPath & fil.Name StringToFile strHtmName, "" & fil.Name & "" & vbCrLf 'If IE5 or greater: AppendLineToFile strHtmName, "" 'If Not IE or less than IE5: AppendLineToFile strHtmName, "" AppendLineToFile strHtmName, "

" AppendLineToFile strHtmName, " " AppendLineToFile strHtmName, "" AppendLineToFile strHtmName, "" AppendLineToFile strHtmName, "" End If Next Next MsgBox "Files have been created." Sub AppendLineToFile(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.WriteLine strText ts.Close End Sub Sub StringToFile(strFileName, strData) 'Writes a string to a file Dim fs 'As Scripting.FileSystemObject Dim ts 'As Scripting.TextStream Const ForWriting = 2 Set fs = CreateObject("Scripting.FileSystemObject") Set ts = fs.OpenTextFile(strFileName, ForWriting, True) ts.Write(strData) ts.Close 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