'Reads WAV, MP3, etc files and creates an HTM file for each one.
'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", "wav, mp3, asf")
If Trim(strExtensions = "") Then WScript.Quit
'Ask where the sound 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 sound files, but with an htm extension. If you enter anything here, it will REPLACE the dot and everything to the end.", "HTM File Name", "_sound.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 sound 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
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