'Generates a PEBuilder menu entry for a directory and
'all subdirectories. The directory can be dropped
'on this script. HTM, INF, and XML files needed to
'construct a BartPE "plugin" will be generated in the
'script directory. The plugin and all files will be
'named the same as the script. Rename the script to
'your desired name before you run it. If there are
'any folders/files in your directory you DON'T want
'to have menus made for, set their properties to
'"Hidden".
'No restrictions. No guarantees.
'Donated to the Public Domain by
'Eric Phelps
'http://www.ericphelps.com
Option Explicit
Dim gstrStartingFolder, gstrFileExtensions
Main
Sub Main()
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
If MsgBox("This will create the INF, XML, and HTM files needed for a ""plugin"" for programs in a ""custom"" added directory for the BartPE Builder from . Continue?", vbYesNo) = vbNo Then Exit Sub
gstrFileExtensions = InputBox("Please enter DOT-DELIMITED file extensions for files you want menus built for.", "File Extensions", "exe.bat.cmd")
If gstrFileExtensions = "" Then Exit Sub
gstrFileExtensions = LCase("." & gstrFileExtensions & ".") 'Makes searching easier later
If Lcase(Right(Wscript.FullName, 12)) = "\wscript.exe" Then
MsgBox "You are running under WSCRIPT. Status messages are only available under CSCRIPT. Please wait for the """ & WScript.ScriptName & " Done!"" message box before you try to use the " & fs.GetBaseName(WScript.ScriptName) & ".htm, " & fs.GetBaseName(WScript.ScriptName) & ".inf, or " & fs.GetBaseName(WScript.ScriptName) & ".xml files."
End If
'Delete existing files
If fs.FileExists(FileNameLikeMine("xml")) Then fs.DeleteFile FileNameLikeMine("xml")
If fs.FileExists(FileNameLikeMine("htm")) Then fs.DeleteFile FileNameLikeMine("htm")
If fs.FileExists(FileNameLikeMine("inf")) Then fs.DeleteFile FileNameLikeMine("inf")
'Get the folder you want info on
If WScript.Arguments.Count = 1 Then
gstrStartingFolder = WScript.Arguments(0)
Else
gstrStartingFolder = BrowseForFolder("Location of ""custom"" directory being added to PEBuilder")
End If
If gstrStartingFolder = "" Then Exit Sub
'Write the INF file
AppendInfLine "; " & fs.GetBaseName(WScript.ScriptName) & ".inf"
AppendInfLine vbCrLf & "[Version]"
AppendInfLine "Signature= ""$Windows NT$"""
AppendInfLine vbCrLf & "[PEBuilder]"
AppendInfLine "Name=""" & fs.GetBaseName(WScript.ScriptName) & """"
AppendInfLine "Enable=1"
AppendInfLine "Help=""" & fs.GetBaseName(WScript.ScriptName) & ".htm"""
AppendInfLine vbCrLf & "[Append]"
AppendInfLine "nu2menu.xml, " & fs.GetBaseName(WScript.ScriptName) & ".xml"
'Write the help file
AppendHtmLine "This plugin will create a "
AppendHtmLine "BartPE plugin for files "
AppendHtmLine "and folders under your """ & gstrStartingFolder & """ directory. "
AppendHtmLine "The plugin was generated by a script whose sole purpose is to create "
AppendHtmLine "the HTM, INF, and XML files needed by BartPE to construct menu "
AppendHtmLine "entries that point directly to programs on the CDROM. Most BartPE "
AppendHtmLine "plugins don't run programs on the CDROM, but copy the programs to a "
AppendHtmLine "ramdisk before running. Not all programs can be run directly from a "
AppendHtmLine "CDROM, but for those that can, this one scripted plugin can handle all "
AppendHtmLine "of them. If you'd like to look at links to several utilities that "
AppendHtmLine "can run directly from a CDROM, check out the "
AppendHtmLine "Dirk "
AppendHtmLine "Loss ""Windows-Tools on CD-ROM"" page. "
AppendHtmLine "
On " & Now & ", you ran the script """ & WScript.ScriptFullName & """, "
AppendHtmLine "which built a menu based on the contents of """ & gstrStartingFolder & """."
AppendHtmLine "At that time, you elected to include only files with the "
AppendHtmLine "following file extensions in the menu:
"
AppendHtmLine Trim(Replace(gstrFileExtensions, ".", " ")) & ". "
AppendHtmLine "
In order for this plugin to succeed, you "
AppendHtmLine "must select ""Add files/folders from (custom) directory"" during "
AppendHtmLine "the PEBuilder manual build process and choose the "
AppendHtmLine """" & gstrStartingFolder & """ folder as your custom folder. "
AppendHtmLine "
If you want to select a different custom folder, or if "
AppendHtmLine "the contents of your previously-chosen folder or sub-folders have "
AppendHtmLine "changed, you should re-run the """ & WScript.ScriptFullName & """ "
AppendHtmLine "script. For ease of use, you can either drop your chosen custom "
AppendHtmLine "folder on the script, pass the custom folder as a command-line argument, "
AppendHtmLine "or just run the script and browse to the custom folder. "
AppendHtmLine "
NOTE: The script will create entries for every subdirectory "
AppendHtmLine "and every program it finds. Hide any file or folder you don't want a menu entry for. "
AppendHtmLine "The script bases the XML linked menu text on the internal file description. "
AppendHtmLine "
The """ & WScript.ScriptFullName & """ script has "
AppendHtmLine "been released into the Public Domain by Eric Phelps. "
AppendHtmLine "You can find the latest (official) version of this script "
AppendHtmLine "here."
'Write the XML file
AppendMenu ""
AppendMenu vbCrLf & ""
RecurseFolders fs.GetFolder(gstrStartingFolder), 1
AppendMenu vbCrLf & ""
If Lcase(Right(Wscript.FullName, 12)) = "\wscript.exe" Then
MsgBox WScript.ScriptName & " Done!"
End If
End Sub
Sub RecurseFolders(objFolder, intDepth)
Dim fols, fol, fil, strXML, strMenuID, blnGotData
Const HIDDEN = 2
'Get the current directory (menu ID) name
If Len(objFolder.Path) = Len(gstrStartingFolder) Then
strMenuID = "Programs"
Else
strMenuID = Mid(objFolder.Path, Len(gstrStartingFolder))
strMenuID = Mid(strMenuID, InStr(strMenuID, "\") + 1)
strMenuID = Replace(strMenuID, "\", "_")
End If
strXML = vbCrLf & String(intDepth, vbTab) & ""
'If we hit an empty folder (no sub-folders, no desired file types), blnGotData is False
If blnGotData Then AppendMenu strXML
'Process the subfolder files
For each fol in fols
'Don't look under hidden folders
If (fol.Attributes And HIDDEN) = 0 Then
RecurseFolders fol, intDepth
End If
Next
End Sub
Function MakePopupXML(fol, intDepth)
Dim fs
Dim intElement
Dim strMenuID, strMenuText, strPopup
Set fs = CreateObject("Scripting.FileSystemObject")
If Len(fol.Path) = Len(gstrStartingFolder) Then
strMenuID = "Programs"
strMenuText = "Programs"
Else
strMenuID = Mid(fol.Path, Len(gstrStartingFolder))
strMenuID = Mid(strMenuID, InStr(strMenuID, "\") + 1)
strMenuID = Replace(strMenuID, "\", "_")
strMenuText = fol.Name
End If
Status strMenuID
strPopup = String(intDepth, vbTab)
strPopup = strPopup & ""
strPopup = strPopup & strMenuText
strPopup = strPopup & ""
MakePopupXML = strPopup
End Function
Function MakeFileXML(fil, intDepth)
Dim fs, sh, shFile, shFol
Dim intElement
Dim blnGotFiles
Dim strName, strCompanyName, strModuleDescription, strProductName
Dim strMenuText, strXML, strMenuExePath
Set fs = CreateObject("Scripting.FileSystemObject")
Set sh = CreateObject("Shell.Application")
Set shFol = sh.Namespace(fil.ParentFolder.Path)
'Start a new menu
strXML = ""
'Process each file in turn
blnGotFiles = False
For Each shFile in shFol.Items
If shFol.GetDetailsOf(shFile, 0) = fil.Name Then
strMenuText = ""
'Show activity
Status vbTab & fil.Name
'Get the data on the program
strName = Trim(shFol.GetDetailsOf(shFile, 0))
strCompanyName = Trim(shFol.GetDetailsOf(shFile, 16))
strModuleDescription = Trim(shFol.GetDetailsOf(shFile, 17))
strProductName = Trim(shFol.GetDetailsOf(shFile, 19))
'Figure out the menu text:
' Microsoft
If strCompanyName = "Microsoft Corporation" Then
strMenuText = strModuleDescription
End If
' Module and Product the same
strMenuText = Trim(strMenuText)
If strMenuText = "" Then
If strModuleDescription <> "" Then
If strModuleDescription = strProductName Then
strMenuText = strModuleDescription
End If
End If
End If
' Module and Product not the same
strMenuText = Trim(strMenuText)
If strMenuText = "" Then
If strProductName <> "" Then
strMenuText = strMenuText & strProductName
End If
If strModuleDescription <> "" Then
If strMenuText <> "" Then strMenuText = strMenuText & " "
strMenuText = strMenuText & "(" & strModuleDescription & ")"
End If
End If
' No Module or Product
strMenuText = Trim(strMenuText)
If strMenuText = "" Then
strMenuText = fs.GetBaseName(strName)
End If
strMenuText = Trim(strMenuText)
'Add the program entry to the menu
strMenuExePath = fil.Path
strMenuExePath = Mid(strMenuExePath, Len(gstrStartingFolder) + 1)
strXML = strXML & String(intDepth, vbTab)
strXML = strXML & ""
strXML = strXML & strMenuText
strXML = strXML & ""
Exit For
End If
Next
MakeFileXML = strXML
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
Sub Status(strMessage)
If Lcase(Right(Wscript.FullName, 12)) = "\cscript.exe" Then
Wscript.Echo strMessage
End If
End Sub
Sub AppendMenu(strText)
Dim fs 'As Scripting.FileSystemObject
Dim ts 'As Scripting.TextStream
Const ForAppending = 8
Set fs = CreateObject("Scripting.FileSystemObject")
Set ts = fs.OpenTextFile(Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & "xml", ForAppending, True)
ts.Write strText
ts.Close
End Sub
Sub AppendInfLine(strText)
Dim fs 'As Scripting.FileSystemObject
Dim ts 'As Scripting.TextStream
Const ForAppending = 8
Set fs = CreateObject("Scripting.FileSystemObject")
Set ts = fs.OpenTextFile(Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & "inf", ForAppending, True)
ts.WriteLine strText
ts.Close
End Sub
Sub AppendHtmLine(strText)
Dim fs 'As Scripting.FileSystemObject
Dim ts 'As Scripting.TextStream
Const ForAppending = 8
Set fs = CreateObject("Scripting.FileSystemObject")
Set ts = fs.OpenTextFile(Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & "htm", ForAppending, True)
ts.WriteLine strText
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 = 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
End Function