I've got the following Function that is designed to recursively read all WMI namespaces on a machine depending on the namespace that's been passed (by default the script calls for ReadWMI("root"). If a WMI namespace contains the name sms or ccm, I want to test writing to that namespace to validate writing works. If Writing to WMI fails in that function, I want to exit the For Loop and completely exit the function.
What I'm noticing is that when I exit the for or exit the function (using either Exit For or Exit Function) I go back to Next instead of exiting the function completely. This causes a number of issues where other namespaces can successfully be written to.
Function ReadWMI(strNameSpace)
Dim oWMI, colNameSpaces, objNameSpace, sFullNamespace
'ReadWMI = "True"
WMI_ReadRepository = "Healthy"
On Error Resume Next
'Verify all namespaces
Set oWMI = GetObject("winmgmts:\\" & sComputer & "\" & strNameSpace)
If Err.Number <> 0 Then
ReadWMI = "False"
WMI_ReadRepository = "Unhealthy"
oLog.WriteLine Now()& " - " & "ReadWMI(): Failed to bind to WMI namespace " & strNamespace & ". Stopping WMI Verification"
oLog.WriteLine Now()& " - " & "ReadWMI(): Error Code: " & Err.Number
'oLog.WriteLine Now()& " - " & "ReadWMI(): Error Description: " & Err.Description
Err.Clear
Exit Function
Else
oLog.WriteLine Now()& " - " & "ReadWMI(): Successfully connected to WMI namespace " & strNamespace
End If
Set colNameSpaces = oWMI.InstancesOf("__NAMESPACE")
For Each objNameSpace In colNameSpaces
sFullNamespace = LCase(strNamespace & "\" & objNamespace.Name)
If InStr(sFullNamespace,"ccm") Or InStr(sFullNamespace,"sms") > 0 Then
oLog.WriteLine Now()& " - " & "ReadWMI(): Writing to " & sFullNamespace & " WMI Namespace if WMIWriteRepository set to TRUE"
If WMIWriteRepository = True Then
If WriteWMI(sFullNamespace) = "False" Then
oLog.WriteLine Now()& " - " & "ReadWMI(): Failed to write to namespace " & sFullNamespace
WMI_ReadRepository = "Unhealthy"
'ReadWMI = "False"
Exit Function
End If
Else
oLog.WriteLine Now()& " - " & "ReadWMI(): WMIWriteRepository set to False or OS is a Server. Will not write to repository."
End If
End If
'Call VerifyWMI again to run through the next namespace
Call ReadWMI(sFullNamespace)
Next
'ReadWMI = "True"
'WMI_ReadRepository = "Healthy"
Set oWMI = Nothing
On Error Goto 0
End Function
If something goes wrong and you want to jump out of the recursive function call, make the return value False (uncomment the 'ReadWMI = "False" in your script).
Your last statement before the next must test if the reading of the WMI was correct, so instead of
Call ReadWMI(sFullNamespace)
use
If ReadWMI(sFullNamespace) = "False" Then
Exit For
End If
Protip: Stop using "string booleans", they are slow and errors are luring around the corner to bite you in the back ("True" <> "true" <> "Treu" <> "True "). Just use True and False. Whenever you want to output a boolean to a string, it is automatically converted to the correct string value:
MsgBox True & " / " & False
' Output: "True / False"
Related
With the following block of code, which accesses an html span element, I am unable to check for errors. When I leave the input box empty and press "ok," the value of Err.Number doesn't change. I have user error checking enabled (On Error Resume Next) and I am checking to make sure that Err.Number is not equal to 0 (an error is ocurring). The error is being thrown, but the value of Err.Number is not changing, and this happens both when On Error Resume Next is on as well as when it is off). By the way, what is the default value of Err.Number? How does that value differ from the value of Err.Number after the Err object is cleared? If I am doing anything wrong or stating any wrong information, please inform me.
On Error Resume Next
Dim updateRate
updateRate = 0
RatePrompt()
Sub RatePrompt
updateRate = InputBox("Please enter an update rate (milliseconds)", "Update Rate")
If Err <> 0 Then
Err.Clear()
MsgBox "No Input Was Specified. Please Specify An Input."
RatePrompt()
Else If updateRate > 2000 then
rateDecision = MsgBox ("Consider entering a lower update rate" & vbCrLf & "Would you like to revise update rate?", _
vbYesNo, "Quiclock Alert")
If rateDecision = vbYes then
RatePrompt()
End If
Else If updateRate < 0 then
MsgBox "Update Rate Not Valid. The Default Value of 0 Milliseconds Will Be Used."
updateRate = 0
Else If updateRate = "" then
MsgBox "Update Rate Adjustment Cancelled. The Default Value of 0 Milliseconds Will Be Used."
updateRate = 0
Else
End If
End If
End If
End If
End Sub
TimerStart()
Sub TimerStart
timerID = window.setTimeout("TimeUpdate", updateRate, "VBScript")
End Sub
Sub TimeUpdate
clockOutput.innerHTML = Time()
window.clearTimeout(timerID)
TimerStart()
End Sub
I have spent a large amount of time researching this problem, but have not come to a conclusion. Thanks for the help.
Try next logic skelet for your script:
Dim updateRate, rateRevision
updateRate = InputBox("Please enter an update rate (milliseconds)", "Update Rate")
If IsEmpty( updateRate) Then
'`Cancel` (or equivalent `Esc` or red `×`) pressed/clicked
Else
If IsNumeric( updateRate) Then
updateRate = CLng( updateRate) 'convert string to a Variant of subtype Long
If updateRate > 2000 Then
' do not bother a user by an additional input: offer a value change right now
rateRevision = InputBox ("Consider entering a lower update rate" _
& vbCrLf & "Would you like to revise update rate?", _
"Quiclock Alert", updateRate)
If IsNumeric( rateRevision) Then
rateRevision = CLng( rateRevision)
If rateRevision > 0 Then updateRate = rateRevision
Else
' keep the value > 2000
End If
ElseIf updateRate < 0 Then
updateRate = 0
Else
''
End If
Else
'non-numeric input, use e.g. default value of zero
updateRate = 0
End If
TimerStart()
End If
An explanation and observation to the code:
There is a mistake in the InputBox Function reference. In fact: if the user clicks Cancel (or the red × or presses Esc), then the function returns an empty value, which looks like a zero-length string ("") due to automatic subtype conversion. See the 32213674.vbs script output below.
Comparison Operators (VBScript) reference shows how expressions are compared or what results from the comparison, depending on the underlying subtype; particularly: if one expression is numeric and the other is a string then the numeric expression is less than the string expression.
32213674.vbs script:
option explicit
On Error GoTo 0
Dim sValInput
Call doOutput( True, sValInput)
Do While True
sValInput = InputBox( _
"Please enter any value (and `OK`) to see its features:" & vbCR _
& "a date-like value, e.g. " & FormatDateTime( Now, vbShortDate) & vbCR _
& "a time-like value, e.g. " & FormatDateTime( Now, vbShortTime) & vbCR _
& "a number-like value, e.g. 123456" & vbCR _
& "a string of your choice" & vbCR _
& "an empty string (i.e. only click `OK`)" & vbCR _
& "or press `Esc` or click red `×` or `Cancel` button to exit the loop" _
, "InputBox test loop")
Call doOutput( False, sValInput)
If IsEmpty( sValInput) Then Exit Do
Loop
Sub doOutput( bHeader, sVal)
If Instr(1, Wscript.FullName, "cscript.exe", vbTextCompare) > 0 Then
If bHeader Then
Wscript.Echo sHead()
Else
Wscript.Echo sLine( sVal)
End If
Else
If bHeader Then
Else
MsgBox( sHead() & vbCR & sLine( sVal))
End If
End If
End Sub
Function sHead()
sHead = "Empty?" & vbTab & "Number?" & vbTab & _
"Date?" & vbTab & "VarType" & vbTab & "TypeName" & "[value]"
End Function
Function sLine( sValue)
sLine = IsEmpty( sValue) & vbTab & IsNumeric( sValue) & vbTab & _
IsDate( sValue) & vbTab & VarType( sValue) & vbTab & _
TypeName( sValue) & vbTab & "[" & sValue & "]"
End Function
Output:
==>cscript //NOLOGO D:\VB_scripts\SO\32213674.vbs
Empty? Number? Date? VarType TypeName[value]
False False True 8 String [2015-08-26]
False False True 8 String [22:01:05]
False True False 8 String [123456]
False False False 8 String [qwertz]
False False False 8 String []
True True False 0 Empty []
I'm writing a VBScript that will simply check each user in AD if their password has been changed within a given number of days. When I was trying to get it working for a single user, I came up with the following working code:
Option Explicit
Dim objUser, strLDAPConnection, intPwdExpLimit
strLDAPConnection = "CN=Test User,OU=Test,OU=Employees,DC=domain,DC=com"
intPwdExpLimit = 90
Set objUser = GetObject("LDAP://" + strLDAPConnection)
WScript.Echo DaysSincePwdChange(objUser)
Function DaysSincePwdChange(objUserAccount)
DaysSincePwdChange = dateDiff("d", objUserAccount.PasswordLastChanged, Now)
End Function
So then I tried to get it to work by looping through all users in a Test OU with the following code:
Option Explicit
Const strOffice = "Test"
Dim objEmployeesOU, objUser, intPwdExpLimit
intPwdExpLimit = 90
Set objEmployeesOU = GetObject("LDAP://OU=" & strOffice & _
",OU=Employees,DC=domain,DC=com")
For Each objUser In objEmployeesOU
If objUser.class = "user" Then
If ((DaysSincePwdChange(objUser)) >= intPwdExpLimit) Then
MsgBox(objUser & ": Password Expired.")
Else
MsgBox(objUser & ": Password Current.")
End If
End If
Next
Function DaysSincePwdChange(objUserAccount)
DaysSincePwdChange = dateDiff("d", objUserAccount.PasswordLastChanged, Now)
End Function
The above code produces a 0x8000500D error and googling the error says that it can't find the property in the cache (referring to the PasswordLastSet property, see error description link here).
Any ideas why the first block of code works fine but the second has a problem accessing that property?
Error code 0x8000500d means E_ADS_PROPERTY_NOT_FOUND. The password of the user has never been changed, so the property is not set. You could handle the condition like this:
Function DaysSincePwdChange(objUserAccount)
On Error Resume Next
DaysSincePwdChange = dateDiff("d", objUserAccount.PasswordLastChanged, Now)
If Err Then
If Err.Number = &h8000500d Then
DaysSincePwdChange = -1
Else
WScript.Echo "Unexpected Error (0x" & Hex(Err.Number) & "): " & _
Err.Description
WScript.Quit 1
End If
End If
End Function
and modify the check like this:
passwordAge = DaysSincePwdChange(objUser)
If passwordAge >= intPwdExpLimit) Then
MsgBox(objUser & ": Password Expired.")
ElseIf passwordAge = -1 Then
MsgBox(objUser & ": Password never changed.")
Else
MsgBox(objUser & ": Password Current.")
End If
I am running into a strange error in VBScript:
[...]
objUser.sAMAccountName = strNTName
On Error Resume Next
objUser.SetInfo
If (Err.Number <> 0) Then
On Error GoTo 0
Wscript.Echo "Unable to create user with NT name: " & strNTName & " - Error-Code: " & Err.Number & " (sAMAccountName)"
Else
[...]
Well I get a message box:
Unable to create user with NT name: testuser - Error-Code: 0 (sAMAccountName)
How can that happen? What am I doing wrong?
Is 0 <> 0?!?
Also tried "0" to be sure...
Update:
Now - thanks to #JosefZ I sorted out the Error code -2147016651
But that does not help me eigther...
New Code:
[...]
Set objUser = objContainer.Create("user", "cn=" & strCN)
If (Err.Number <> 0) Then
On Error GoTo 0
Wscript.Echo "Unable to create user with cn: " & strCN
Else
On Error GoTo 0
' Assign mandatory attributes and save user object.
If (strNTName = "") Then
strNTName = strCN
End If
objUser.sAMAccountName = strNTName
On Error Resume Next
objUser.SetInfo
If (Err.Number <> 0) Then
Wscript.Echo "Unable to create user with NT name: " & strNTName & " - Error-Code: " & Err.Number & " (sAMAccountName)"
On Error GoTo 0
Else
[...]
strNTName is testuser (no spaces - checked that)
strCN is 'Test User' (no other chars before or after and without the quotes of course)
Poorly documented that On Error GoTo 0 statement calls the Clear method automatically. Therefore, use
'[...]
objUser.sAMAccountName = strNTName
On Error Resume Next
objUser.SetInfo
If (Err.Number <> 0) Then
Wscript.Echo "Unable to create user with NT name: " & strNTName & " - Error-Code: " & Err.Number & " (sAMAccountName)"
On Error GoTo 0
Else
'[...]
I have a function that pings computers from an excel list and gets the ping value of them.
While the script was running, the excel was completely unresponsive. I could fix this with DoEvents, this made it a bit more responsive.
However, the problem starts when the function gets to an offline computer. While it waits for the response of the offline PC, Excel freezes again and the script does not jump to the next PC until it gets the "timeout" from the actual one.
As the default ping timeout value is 4000ms, if I have 100 computers in my list, and 50 of them are turned off, that means I have to wait an extra 3,3 minutes for the script to finish, and also blocks the entire Excel, making it unusable for the duration.
My question is, if is there any way to make this faster or more responsive or smarter?
The actual code:
Function:
Function sPing(sHost) As String
Dim oPing As Object, oRetStatus As Object
Set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & sHost & "'")
DoEvents
For Each oRetStatus In oPing
DoEvents
If IsNull(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
sPing = "timeout" 'oRetStatus.StatusCode <- error code
Else
sPing = sPing & vbTab & oRetStatus.ResponseTime
End If
Next
End Function
Main:
Sub pingall_Click()
Dim c As Range
Dim p As String
Dim actives As String
actives = ActiveSheet.Name
StopCode = False
Application.EnableCancelKey = xlErrorHandler
On Error GoTo ErrH:
DoEvents
For Each c In Sheets(actives).UsedRange.Cells
If StopCode = True Then
Exit For
End If
DoEvents
If Left(c, 7) = "172.21." Then
p = sPing(c)
[...]
End If
Next c
End Sub
As already noted in the comments, to prevent this from blocking after each call, you need to invoke your pings asynchronously from your function. The way I would approach this would be to delegate your sPing(sHost) function to a VBScript that you create on the fly in a temp folder. The script would look something like this, and it takes the IP address as a command line argument and outputs the result to a file:
Dim args, ping, status
Set ping = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & Wscript.Arguments(0) & "'")
Dim result
For Each status In ping
If IsNull(status.StatusCode) Or status.StatusCode <> 0 Then
result = "timeout"
Else
result = result & vbTab & status.ResponseTime
End If
Next
Dim fso, file
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.CreateTextFile(Wscript.Arguments(0), True)
file.Write result
file.Close
You can create a Sub to write this to a path something like this:
Private Sub WriteScript(path As String)
Dim handle As Integer
handle = FreeFile
Open path & ScriptName For Output As #handle
Print #handle, _
"Dim args, ping, status" & vbCrLf & _
"Set ping = GetObject(""winmgmts:{impersonationLevel=impersonate}"").ExecQuery _" & vbCrLf & _
" (""select * from Win32_PingStatus where address = '"" & Wscript.Arguments(0) & ""'"")" & vbCrLf & _
"Dim result" & vbCrLf & _
"For Each status In ping" & vbCrLf & _
" If IsNull(status.StatusCode) Or status.StatusCode <> 0 Then" & vbCrLf & _
" result = ""timeout""" & vbCrLf & _
" Else" & vbCrLf & _
" result = result & vbTab & status.ResponseTime" & vbCrLf & _
" End If" & vbCrLf & _
"Next" & vbCrLf & _
"Dim fso, file" & vbCrLf & _
"Set fso = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _
"Set file = fso.CreateTextFile(Wscript.Arguments(0), True)" & vbCrLf & _
"file.Write result" & vbCrLf & _
"file.Close"
Close #handle
End Sub
After that, it's pretty straightforward - create a new directory in the user's temp directory, plop the script in there, and then use the Shell command to run each ping in its own process. Wait for the length of your timeout, then read the results from the files:
Private Const TempDir = "\PingResults\"
Private Const ScriptName As String = "ping.vbs"
'Important - set this to the time in seconds of your ping timeout.
Private Const Timeout = 4
Sub pingall_Click()
Dim sheet As Worksheet
Set sheet = ActiveSheet
Dim path As String
'Create a temp folder to use.
path = Environ("Temp") & TempDir
MkDir path
'Write your script to the temp folder.
WriteScript path
Dim results As Dictionary
Set results = New Dictionary
Dim index As Long
Dim ip As Variant
Dim command As String
For index = 1 To sheet.UsedRange.Rows.Count
ip = sheet.Cells(index, 1)
If Len(ip) >= 7 Then
If Left$(ip, 1) = "172.21." Then
'Cache the row it was in.
results.Add ip, index
'Shell the script.
command = "wscript " & path & "ping.vbs " & ip
Shell command, vbNormalFocus
End If
End If
Next index
Dim completed As Double
completed = Timer + Timeout
'Wait for the timeout.
Do While Timer < completed
DoEvents
Loop
Dim handle As String, ping As String, result As String
'Loop through the resulting files and update the sheet.
For Each ip In results.Keys
result = Dir$(path & ip)
If Len(result) <> 0 Then
handle = FreeFile
Open path & ip For Input As #handle
ping = Input$(LOF(handle), handle)
Close #handle
Kill path & ip
Else
ping = "timeout"
End If
sheet.Cells(results(ip), 2) = ping
Next ip
'Clean up.
Kill path & "*"
RmDir path
End Sub
Note that this has exactly zero error handling for the file operations, and doesn't respond to your StopCode flag. It should give the basic gist of it though. Also note that if you need to allow the user to cancel it, you won't be able to remove the temp directory because it will still be in use. If that is the case, only create it if it isn't already there and don't remove it when you're done.
You might be able to implement something like this, but I haven't tried it with multiple servers
if your network is fast you can reduce the timeout to 500 ms or less:
.
Public Function serverOk(ByVal dbSrvrNameStr As String) As Boolean
Const PINGS As Byte = 1
Const PING_TIME_OUT As Byte = 500
Const PING_LOCATION As String = "C:\Windows\System32\"
Dim commandResult As Long, serverIsActive As Boolean
commandResult = 1
serverIsActive = False
If Len(dbSrvrNameStr) > 0 Then
Err.Clear
With CreateObject("WScript.Shell")
commandResult = .Run("%comspec% /c " & PING_LOCATION & "ping.exe -n " & PINGS & " -w " & PING_TIME_OUT & " " & dbSrvrNameStr & " | find ""TTL="" > nul 2>&1", 0, True)
commandResult = .Run("%comspec% " & PING_LOCATION & "/c ping.exe -n " & PINGS & " -w " & PING_TIME_OUT & " " & dbSrvrNameStr, 0, True)
serverIsActive = (commandResult = 0)
End With
If serverIsActive And Err.Number = 0 Then
'"DB Server - valid, Ping response: " & commandResult
Else
'"Cannot connect to DB Server, Error: " & Err.Description & ", Ping response: " & commandResult
End If
Err.Clear
End If
serverOk = serverIsActive
End Function
.
Link to "Run Method (Windows Script Host)" from Microsoft:
https://msdn.microsoft.com/en-us/library/d5fk67ky(VS.85).aspx
The 3rd parameter of this command can be overlooked: "bWaitOnReturn" - allows you to execute it asynchronously from VBA
Is there a way to write anonymous functions, pass them to other functions, in which they are invoked, in vbscript?
There are no anonymous functions/subs/methods in VBScript.
You can use GetRef() (see sample1, sample2) to get something like a function pointer that can be passed to functions/subs to be invoked there (callback). But there are no closures in VBScript, so tricks possible in other languages fail in VBScript.
For specific problems that can be solved with higher order functions in functional languages there may be (nearly) equivalent VBScript solutions involving classes/objects; but for discussing that approach you need to describe your/such a problem in detail.
VBScript has the ability to execute arbitatry code.
Execute and Eval just do what they say to a string containing code.
ExecuteGlobal adds code to your program, like a new function, new variables.
Script Control adds vbscript/jscript scripting language to any program including vbscripts. It can have access to the host's data.
If using ExecuteGlobal/Execute/Eval it is best to run through a scriptcontrol first to test for syntax errors (as you can't trap syntax errors, but you can trap the runtime error the script control gives off on a syntax error).
So you can build your program at runtime.
Set Arg = WScript.Arguments
set WshShell = createObject("Wscript.Shell")
Set Inp = WScript.Stdin
Set Outp = Wscript.Stdout
Sub VBSCmd
RawScript = LCase(Arg(1))
'Remove ^ from quoting command line and replace : with vbcrlf so get line number if error
Script = Replace(RawScript, "^", "")
Script = Replace(Script, "'", chr(34))
Script = Replace(Script, ":", vbcrlf)
'Building the script with predefined statements and the user's code
Script = "Dim gU" & vbcrlf & "Dim gdU" & vbcrlf & "Set gdU = CreateObject(" & chr(34) & "Scripting.Dictionary" & chr(34) & ")" & vbcrlf & "Function UF(L, LC)" & vbcrlf & "Set greU = New RegExp" & vbcrlf & "On Error Resume Next" & vbcrlf & Script & vbcrlf & "End Function" & vbcrlf
'Testing the script for syntax errors
On Error Resume Next
set ScriptControl1 = wscript.createObject("MSScriptControl.ScriptControl",SC)
With ScriptControl1
.Language = "VBScript"
.UseSafeSubset = False
.AllowUI = True
.AddCode Script
End With
With ScriptControl1.Error
If .number <> 0 then
Outp.WriteBlankLines(1)
Outp.WriteLine "User function syntax error"
Outp.WriteLine "=========================="
Outp.WriteBlankLines(1)
Outp.Write NumberScript(Script)
Outp.WriteBlankLines(2)
Outp.WriteLine "Error " & .number & " " & .description
Outp.WriteLine "Line " & .line & " " & "Col " & .column
Exit Sub
End If
End With
ExecuteGlobal(Script)
'Remove the first line as the parameters are the first line
'Line=Inp.readline
Do Until Inp.AtEndOfStream
Line=Inp.readline
LineCount = Inp.Line
temp = UF(Line, LineCount)
If err.number <> 0 then
outp.writeline ""
outp.writeline ""
outp.writeline "User function runtime error"
outp.writeline "==========================="
Outp.WriteBlankLines(1)
Outp.Write NumberScript(Script)
Outp.WriteBlankLines(2)
Outp.WriteLine "Error " & err.number & " " & err.description
Outp.WriteLine "Source " & err.source
Outp.WriteLine "Line number and column not available for runtime errors"
wscript.quit
End If
outp.writeline temp
Loop
End Sub
Vbs
filter vbs "text of a vbs script"
filter vb "text of a vbs script"
Use colons to seperate statements and lines. Use single quotes in place of double quotes, if you need a single quote use chr(39). Escape brackets and ampersand with the ^ character. If you need a caret use chr(136).
The function is called UF (for UserFunction). It has two parameters, L which contains the current line and LC which contains the linecount. Set the results of the script to UF. See example.
There are three global objects available. An undeclared global variable gU to maintain state. Use it as an array if you need more than one variable. A Dictionary object gdU for saving and accessing previous lines. And a RegExp object greU ready for use.
Example
This vbs script inserts the line number and sets the line to the function UF which Filter prints.
filter vbs "uf=LC ^& ' ' ^& L"<"%systemroot%\win.ini"
This is how it looks in memory
Dim gU
Set gdU = CreateObject("Scripting.Dictionary")
Set greU = New RegExp
Function UF(L, LC)
---from command line---
uf=LC & " " & L
---end from command line---
End Function
If there is a syntax error Filter will display debugging details.
User function syntax error
==========================
1 Dim gU
2 Dim gdU
3 Set greU = CreateObject("Scripting.Dictionary")
4 Function UF(L, LC)
5 On Error Resume Next
6 uf=LC dim & " " & L
7 End Function
Error 1025 Expected end of statement
Line 6 Col 6
User function runtime error
===========================
1 Dim gU
2 Dim gdU
3 Set greU = CreateObject("Scripting.Dictionary")
4 Function UF(L, LC)
5 On Error Resume Next
6 uf=LC/0 & " " & L
7 End Function
Error 11 Division by zero
Source Microsoft VBScript runtime error
Line number and column not available for runtime errors
the funny thing about function objects is that they by definition are a memory leak. This means that once you create a function object, you need to keep the scope it was created in intact, which threw me off.
Class VBCompiler
Public leaks
Public Sub Class_Initialize()
leaks = Array()
End Sub
Public Function Compile(code)
Dim compiler, result
Set compiler = CreateObject("MSScriptControl.ScriptControl")
Set portal = CreateObject("Scripting.Dictionary")
Dim name
compiler.Language = "VBScript"
compiler.AddObject "portal", portal, True
compiler.ExecuteStatement code
name = compiler.Procedures(1).Name
compiler.ExecuteStatement "portal.Add ""result"", GetRef(""" & name & """)"
' save the script control because if we go out of scope...
' our function object goes poof!
' leaks.Push compiler
ReDim Preserve leaks(UBound(leaks) + 1)
Set leaks(UBound(leaks)) = compiler
Set Compile = portal("result")
End Function
End Class
Dim z
Set z = New VBCompiler
Set z2 = z.Compile("Function Foo(s):MsgBox s:Foo = 2:End Function")
z2("Hi!")
z2 "Hello Again!"
Gives the two message boxes as desired
Class VBCompiler
Public Function Compile(code)
Dim compiler, result
Set compiler = CreateObject("MSScriptControl.ScriptControl")
Set portal = CreateObject("Scripting.Dictionary")
Dim name
compiler.Language = "VBScript"
compiler.AddObject "portal", portal, True
compiler.ExecuteStatement code
name = compiler.Procedures(1).Name
compiler.ExecuteStatement "portal.Add ""result"", GetRef(""Foo"") "
Set Compile = portal("result")
End Function
End Class
Dim z
Set z = New VBCompiler
Set z2 = z.Compile("Function Foo():MsgBox ""Well Met!"":Foo = 2:End Function")
z2("Hi!")
z2 "Hello Again!"
The above gives (29, 5) (null): Unspecified error. This error is in essence: your object has committed suicide.
This approach can be improved(in particular, the issue of wasteful one ScriptControl per compilation without any plans to release them).