Delegate
This class module defines what I'm calling, in this context, a Delegate - here a function that can take a number of parameters, evaluate a result, and return a value. Close enough to the actual "delegate" thing I find.
Example usage
Set x = Delegate.Create("(x) => MsgBox(""Hello, "" & x & ""!"")")
x.Execute "Mug"
The Execute call will generate this code in a dedicated code module found in the Reflection project (I know, it should be indented... but hey it's generated code!):
Public Function AnonymousFunction(ByVal x As Variant) As Variant
AnonymousFunction = MsgBox("Hello, " & x & "!")
End Function
Then it will call it (here with parameter value "Mug"), resulting in this:
And this would output VbMsgBoxResult.vbOK, which has a value of 1:
Debug.Print x.Execute("Mug")
Now that's all nice, but I didn't write this class to display "Hello" message boxes; with it I can create a Delegate instance, and pass it as a parameter to a function, say, this member of some Enumerable class:
Public Function Where(predicate As Delegate) As Enumerable
Dim result As New Collection
Dim element As Variant
For Each element In this.Encapsulated
If predicate.Execute(element) Then result.Add element
Next
Set Where = Enumerable.FromCollection(result)
End Function
I've always wanted to be able to do this. Enough talk, here's the code that enables this sorcery!
Option Explicit
Private Type TDelegate
Body As String
Parameters As New Collection
End Type
Private Const methodName As String = "AnonymousFunction"
Private this As TDelegate
Friend Property Get Body() As String
Body = this.Body
End Property
Friend Property Let Body(ByVal value As String)
this.Body = value
End Property
Public Function Create(ByVal expression As String) As Delegate
Dim result As New Delegate
Dim regex As New RegExp
regex.Pattern = "\((.*)\)\s\=\>\s(.*)"
Dim regexMatches As MatchCollection
Set regexMatches = regex.Execute(expression)
If regexMatches.Count = 0 Then
Err.Raise 5, "Delegate", "Invalid anonymous function expression."
End If
Dim regexMatch As Match
For Each regexMatch In regexMatches
If regexMatch.SubMatches(0) = vbNullString Then
result.Body = methodName & " = " & Right(expression, Len(expression) - 6)
Else
Dim params() As String
params = Split(regexMatch.SubMatches(0), ",")
Dim i As Integer
For i = LBound(params) To UBound(params)
result.AddParameter Trim(params(i))
Next
result.Body = methodName & " = " & regexMatch.SubMatches(1)
End If
Next
Set Create = result
End Function
Public Function Execute(ParamArray params()) As Variant
On Error GoTo CleanFail
Dim paramCount As Integer
paramCount = UBound(params) + 1
GenerateAnonymousMethod
'cannot break beyond this point
Select Case paramCount
Case 0
Execute = Application.Run(methodName)
Case 1
Execute = Application.Run(methodName, params(0))
Case 2
Execute = Application.Run(methodName, params(0), params(1))
Case 3
Execute = Application.Run(methodName, params(0), params(1), params(2))
Case 4
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3))
Case 5
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4))
Case 6
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5))
Case 7
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5), _
params(6))
Case 8
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5), _
params(6), params(7))
Case 9
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5), _
params(6), params(7), params(8))
Case 10
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5), _
params(6), params(7), params(8), _
params(9))
Case Else
Err.Raise 5, "Execute", "Too many parameters."
End Select
CleanExit:
DestroyAnonymousMethod
Exit Function
CleanFail:
Resume CleanExit
End Function
Friend Sub AddParameter(ByVal paramName As String)
this.Parameters.Add "ByVal " & paramName & " As Variant"
End Sub
Private Sub GenerateAnonymousMethod()
Dim component As VBComponent
Set component = Application.VBE.VBProjects("Reflection").VBComponents("AnonymousCode")
Dim params As String
If this.Parameters.Count > 0 Then
params = Join(Enumerable.FromCollection(this.Parameters).ToArray, ", ")
End If
Dim signature As String
signature = "Public Function " & methodName & "(" & params & ") As Variant" & vbNewLine
Dim content As String
content = vbNewLine & signature & this.Body & vbNewLine & "End Function" & vbNewLine
component.CodeModule.DeleteLines 1, component.CodeModule.CountOfLines
component.CodeModule.AddFromString content
End Sub
Private Sub DestroyAnonymousMethod()
Dim component As VBComponent
Set component = Application.VBE.VBProjects("Reflection").VBComponents("AnonymousCode")
component.CodeModule.DeleteLines 1, component.CodeModule.CountOfLines
End Sub
The regular expression is pretty permissive; I'm basically allowing anything between parentheses, followed by =>, and then anything goes. I'd like a regex that enforces an optional comma-separated list of parameters between the parentheses, at least.
The reason I'd want a stiffer regex, is because it's my only chance to catch and prevent syntax errors that would generate uncompilable code, like..
Set x = Delegate.Create("(this is a bad parameter) => MsgBox(""Hello, "" & x & ""!"")")
Which generates this uncompilable code:
Public Function AnonymousFunction(ByVal this is a bad parameter As Variant) As Variant
AnonymousFunction = MsgBox("Hello, " & x & "!")
End Function
The actual anonymous function doesn't get generated until the Execute function is called, and then the anonymous function gets destroyed before Execute exits - this way one could have 20 Delegate objects with as many different anonymous functions waiting to be executed. The flipside is an obvious performance hit, especially with usages such as the Where method shown above - the same method would get created, executed and destroyed 200 times if the encapsulated collection has 200 elements.
Appending the expression body to the function's name induces a limitation - the "body" may only be a one-liner. I can live with that, but I wonder if there wouldn't be a way to make it smarter.
content = vbNewLine & signature & vbTab & this.Body & vbNewLine & "End Function" & vbNewLine\$\endgroup\$returnstatement for this to work; honestly indenting code that can't even be seen/debugged isn't a real concern ;) \$\endgroup\$ParamArray\$\endgroup\$Application.Run... \$\endgroup\$ParamArray, nope it takes 30 optional parameters... \$\endgroup\$