Summary: Other languages treat functions more as first class citizens in that one can pass a function pointer (C++) around just like a variable. In C# there are function delegates which are like an object orientated version of function pointers. We can do something similar in VBA but there is an unfortunately duality that needs to be unified or abstracted.
So other languages like C++ have function pointers which can be used for callbacks (for say event handling) or the visitor design pattern (think of passing a comparison function into a C++ sort routine). Indeed, in C++ a pointer to a COM interface is in fact a pointer a whole table of function pointers. C# has function delegates which are like object orientated versions of C++ function pointers. In VBA, we can do something like function delegates of C# but not the pointers of C++ because VBA does not have pointers. Both C++ and C# will score higher than anything I can write in VBA because they have argument type checking. Moreover, VBA will never have inline function definitions like they have in Javascript or (as far as I can see) lambda expressions.
The real problem in VBA is the duality between calling a function in a standard module using Application.Run() and calling a function of a class instance using VBA.CallByname(). We can solve this by adding a class to route execution to the correct branch of code.
Without pulling a trick the extra layer will mean that the code has to read with the Run method being visible, this is not as nice as C++ or C#.
fnFoo.Run("bar","barry")But we can pull a trick to hide the Run() by adding an attribute to the Run making its DispID = 0 added layer. This needs to be done on a code module that has been exported and edited in a text editor (Notepad). VBA has a different name for DispID, they call VB_UserMemId = 0 so the attribute line to add in an exported code module is as following.
Attribute Item.VB_UserMemId = 0Once this atribute is added, the text file saved and re-imported into VBA project we can then call the same line of code without Run thus ...
fnFoo("bar","barry")So the code is given below. There are two core classes FnFactory and FunctionDelegate and three test modules (2 classes+1 standard module) FunctionDelegateTestClass, tstFunctionDelegate and AsynchronousWebCall. So import these into a fresh workbook VBA project. You'll need a reference to Microsoft WinHTTP Services, version 5.1 (C:\WINDOWS\system32\winhttpcom.dll) for the AsynchronousWebCall class to compile. Then run the tests.
The AsynchronousWebCall class and its calling code given here show the compact syntax I was aiming for in terms of specifying which functions to call for each event of OnError and OnResponseFinished on an XHR. This is as tight and as close as I can get to the Javascript syntax for ajax calls but is quite satisfactory (to me at least).
Private Sub Test_AsynchronousWebCall_CompactSyntax()
'* run this test to see function delegates in action, this has compact syntax
Static oAsyncXHR As AsynchronousWebCall '<--- needs to (a) static is locally scoped or (b) module or globally scope
Set oAsyncXHR = New AsynchronousWebCall
Call oAsyncXHR.RunAsynchronous("GET", "https://stackoverflow.com/questions/tagged/vba", _
FnFactory.FnAppRun("TestOnError"), _
FnFactory.FnAppRun("TestOnResponseFinished"))
End SubThe Code Listings
The FnFactory class
This Contains factory methods to frees us from the syntactical constraints around the New keyword.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "FnFactory"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'---------------------------------------------------------------------------------------
' Module : FnFactory
' DateTime : 06/02/2018 15:57
' Author : Simon
' Purpose : Contains factory methods to frees us from the syntactical constraints
' around the New keyword
' Deployment: Open a text editor and ensure the line reads "Attribute VB_PredeclaredId = True"
' so that one will not need to New this module!
'---------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
' Procedure : FnAppRun
' DateTime : 05/02/2018 14:05
' Author : Simon
' Purpose : A factory method to create a FunctionDelegate containing enough info
' to pass to Application.Run(.. , .. , .. , ...)
' Using a factory method frees us from the syntactical constraints
' around the New keyword
'---------------------------------------------------------------------------------------
' Arguments :
' [in] sMacro : the name of macro passed to Application.Run
' [in] bReturnTypeIsObject : whether or not we need to say 'Set foo=Application.Run(...' for returning an object
' [out,retval] : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnAppRun(ByVal sMacro As String, Optional ByVal bReturnTypeIsObject As Boolean) As FunctionDelegate
Dim oNewFD As FunctionDelegate
Set oNewFD = New FunctionDelegate
oNewFD.IsAppRun = True
oNewFD.AppRunMacro = sMacro
oNewFD.ReturnTypeIsObject = bReturnTypeIsObject
'oNewFD.mvArgs = vargs
Set FnAppRun = oNewFD
End Function
'---------------------------------------------------------------------------------------
' Procedure : FnCallByName
' DateTime : 06/02/2018 15:50
' Author : Simon
' Purpose : A factory method to create a FunctionDelegate containing enough info
' to pass to VBA.CallByName(.. , .. , .. , ...)
' Using a factory method frees us from the syntactical constraints
' around the New keyword
'---------------------------------------------------------------------------------------
' Arguments :
' [in] oCallByNameTarget : the object (class instance) on whom we want to call the method
' [in] sMacro : the name of method we want to call
' [in] eCallByNameType : necessary to specify one of {VbSet, VbMethod, VbLet, VbGet}
' [in] bReturnTypeIsObject : whether or not we need to say 'Set foo=VBA.CallByName(...' for returning an object
' [out,retval] : returns a create instance of FunctionDelegate containing the passed details
'
Public Function FnCallByName(ByVal oCallByNameTarget As Object, ByVal sMacro As String, _
ByVal eCallByNameType As VbCallType, Optional bReturnTypeIsObject As Boolean) As FunctionDelegate
Dim oNewFD As FunctionDelegate
Set oNewFD = New FunctionDelegate
oNewFD.IsAppRun = False
Set oNewFD.CallByNameTarget = oCallByNameTarget
oNewFD.ReturnTypeIsObject = bReturnTypeIsObject
oNewFD.CallByNameType = eCallByNameType
oNewFD.AppRunMacro = sMacro
'oNewFD.mvArgs = vargs
Set FnCallByName = oNewFD
End FunctionThe FunctionDelegate class
This class contains enough information to call a function either using (a) Application.Run() if function lives in a standard module or (b) VBA.CallByName() if function lives in a class instance (object). It is recommended (but not necessary) one uses the FnFactory class for more compact code for instantiation of this class.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "FunctionDelegate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'---------------------------------------------------------------------------------------
' Module : FunctionDelegate
' DateTime : 06/02/2018 16:04
' Author : Simon
' Purpose : Contains enough information to call a function either using
' (a) Application.Run() if function lives in a standard module or
' (b) VBA.CallByName() if function lives in a class instance (object)
'
' Recommended (but not necessary) one uses the FnFactory class for more compact
' code for instantiation of this class.
'---------------------------------------------------------------------------------------
Private msAppRunMacro As String
Private mobjCallByNameTarget As Object
Private meCallByNameType As VbCallType
Private mbIsAppRun As Boolean
Private mbReturnTypeIsObject As Boolean
Public Property Get ReturnTypeIsObject() As Boolean
ReturnTypeIsObject = mbReturnTypeIsObject
End Property
Public Property Let ReturnTypeIsObject(ByVal bReturnTypeIsObject As Boolean)
mbReturnTypeIsObject = bReturnTypeIsObject
End Property
Public Property Get IsAppRun() As Boolean
IsAppRun = mbIsAppRun
End Property
Public Property Let IsAppRun(ByVal bIsAppRun As Boolean)
mbIsAppRun = bIsAppRun
End Property
Public Property Get CallByNameType() As VbCallType
CallByNameType = meCallByNameType
End Property
Public Property Let CallByNameType(ByVal eCallByNameType As VbCallType)
meCallByNameType = eCallByNameType
End Property
Public Property Get CallByNameTarget() As Object
Set CallByNameTarget = mobjCallByNameTarget
End Property
Public Property Set CallByNameTarget(ByVal objCallByNameTarget As Object)
Set mobjCallByNameTarget = objCallByNameTarget
End Property
Public Property Get AppRunMacro() As String
AppRunMacro = msAppRunMacro
End Property
Public Property Let AppRunMacro(ByVal sAppRunMacro As String)
msAppRunMacro = sAppRunMacro
End Property
'---------------------------------------------------------------------------------------
' Procedure : Run
' DateTime : 06/02/2018 16:01
' Author : Simon
' Purpose : This runs/executes/calls the function. Deployed correctly one can omit
' .Run in the calling line see unit tests for example
'
' Deployment: *** need to ensure that this has the line "Attribute Item.VB_UserMemId = 0"
' to make it default ***
'---------------------------------------------------------------------------------------
' Arguments :
' vargs() : a variable list of arguments which we'll pass on to Application.Run()
' or VBA.CallByName()
'
Public Function Run(ParamArray vargs() As Variant)
Attribute Run.VB_UserMemId = 0
Dim lArgCount As Long
lArgCount = UBound(vargs) - LBound(vargs) + 1
If mbIsAppRun Then
If lArgCount = 0 Then
If mbReturnTypeIsObject Then
Set Run = Application.Run(msAppRunMacro)
Else
Run = Application.Run(msAppRunMacro)
End If
ElseIf lArgCount = 1 Then
If mbReturnTypeIsObject Then
Set Run = Application.Run(msAppRunMacro, vargs(0))
Else
Run = Application.Run(msAppRunMacro, vargs(0))
End If
ElseIf lArgCount = 2 Then
If mbReturnTypeIsObject Then
Set Run = Application.Run(msAppRunMacro, vargs(0), vargs(1))
Else
Run = Application.Run(msAppRunMacro, vargs(0), vargs(1))
End If
Else
'requires more lines to handle multiple arguments,
'a bit ugly so will do later
End If
Else
If Not mobjCallByNameTarget Is Nothing Then
If lArgCount = 0 Then
If mbReturnTypeIsObject Then
Set Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType)
Else
Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType)
End If
ElseIf lArgCount = 1 Then
If mbReturnTypeIsObject Then
Set Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType, vargs(0))
Else
Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType, vargs(0))
End If
ElseIf lArgCount = 2 Then
If mbReturnTypeIsObject Then
Set Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType, vargs(0), vargs(1))
Else
Run = CallByName(mobjCallByNameTarget, msAppRunMacro, meCallByNameType, vargs(0), vargs(1))
End If
Else
'requires more lines to handle multiple arguments,
'a bit ugly so will do later
End If
End If
End If
End Function
The FunctionDelegateTestClass class
This is test fodder for the function delegate and is not core to the application; we need to test the CallByName use case so we need a class and some methods to call.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "FunctionDelegateTestClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'---------------------------------------------------------------------------------------
' Module : FunctionDelegateTestClass
' DateTime : 06/02/2018 16:38
' Author : Simon
' Purpose : To house some procedures to be called using instances of FunctionDelegate
' (not really to be called directly)
'---------------------------------------------------------------------------------------
Public Sub CallByNameZeroArg()
'DO NOT RUN THIS DIRECTLY IT IS HERE TO BE CALLED AS PART OF A TEST
Debug.Print "ClassTestForDelegates.CallByNameZeroArg called"
End Sub
Public Function CallByNameZeroArgReturnString() As String
'DO NOT RUN THIS DIRECTLY IT IS HERE TO BE CALLED AS PART OF A TEST
Debug.Print "ClassTestForDelegates.CallByNameZeroArg called"
CallByNameZeroArgReturnString = "returned String"
End Function
Public Function CallByNameZeroArgReturnObject() As Workbook
'DO NOT RUN THIS DIRECTLY IT IS HERE TO BE CALLED AS PART OF A TEST
Debug.Print "ClassTestForDelegates.CallByNameZeroArg called"
Set CallByNameZeroArgReturnObject = ThisWorkbook
End Function
The tstFunctionDelegate standard module
The standard module houses both unit tests and some function which we call via delegates.
Attribute VB_Name = "tstFunctionDelegate"
Option Explicit
Option Private Module
'---------------------------------------------------------------------------------------
' Module : tstFunctionDelegate
' DateTime : 06/02/2018 16:26
' Author : Simon
' Purpose : Unit tests that also serve as sample calling syntax
'---------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
' Procedure : Test_FunctionDelegateFactory_Suite
' DateTime : 06/02/2018 16:48
' Author : Simon
' Purpose : Runs the test suite
'---------------------------------------------------------------------------------------
'
Private Sub Test_FunctionDelegateFactory_Suite()
Test_FunctionDelegateFactory_FnAppRun
Test_FunctionDelegateFactory_FnAppRun_DispID0
Test_FunctionDelegateFactory_FnCallByName
Test_FunctionDelegateFactory_FnCallByName_DispID0
Test_AsynchronousWebCall_CompactSyntax
Test_AsynchronousWebCall_FullerSyntax
End Sub
Private Sub TestOnError(ByVal lErrorNo As Long, ByVal sErrDesc As String)
'DO NOT RUN THIS DIRECTLY IT IS HERE TO BE CALLED AS PART OF A TEST
'* this is called by AsynchronousWebCall when handling the OnError event
Debug.Print "TestOnError", lErrorNo, sErrDesc
End Sub
Private Sub TestOnResponseFinished(ByVal sResponseText As String)
'DO NOT RUN THIS DIRECTLY IT IS HERE TO BE CALLED AS PART OF A TEST
'* this is called by AsynchronousWebCall when handling the OnResponseFinished event
Debug.Print "TestOnResponseFinished"
Debug.Print Left$(sResponseText, 50)
End Sub
Private Sub Test_FunctionDelegateFactory_FnAppRun()
'* run this test to test calling function delegate based on application.run
Dim fnFoo As FunctionDelegate
Set fnFoo = FnFactory.FnAppRun("SubFooZero", False)
Call fnFoo.Run
Dim fnFoo1 As FunctionDelegate
Set fnFoo1 = FnFactory.FnAppRun("SubFooOne", False)
Call fnFoo1.Run("hello")
Call fnFoo1("hello") '<--- with DispID=0 we can pull a default member trick and omit Run
End Sub
Private Sub Test_FunctionDelegateFactory_FnAppRun_DispID0()
'* run this test to test calling function delegate based on application.run
'* also testing the omission of Run by using DispID=0
Dim fnFoo As FunctionDelegate
Set fnFoo = FnFactory.FnAppRun("SubFooZero", False)
Call fnFoo '<--- with DispID=0 we can pull a default member trick and omit Run
End Sub
Private Sub Test_FunctionDelegateFactory_FnCallByName()
'* run this test to test calling function delegate based on vba.callbyname
Dim oTarget As FunctionDelegateTestClass
Set oTarget = New FunctionDelegateTestClass
Dim fnCBN As FunctionDelegate
Set fnCBN = FnFactory.FnCallByName(oTarget, "CallByNameZeroArg", VbMethod, False)
fnCBN.Run
Dim fnCBN2 As FunctionDelegate
Set fnCBN2 = FnFactory.FnCallByName(oTarget, "CallByNameZeroArgReturnString", VbMethod, False)
Debug.Print fnCBN2.Run
Dim fnCBN3 As FunctionDelegate
Set fnCBN3 = FnFactory.FnCallByName(oTarget, "CallByNameZeroArgReturnObject", VbMethod, True)
Debug.Print fnCBN3.Run.Name
End Sub
Private Sub Test_FunctionDelegateFactory_FnCallByName_DispID0()
'* run this test to test calling function delegate based on vba.callbyname
'* also testing the omission of Run by using DispID=0
Dim oTarget As FunctionDelegateTestClass
Set oTarget = New FunctionDelegateTestClass
Dim fnFoo As FunctionDelegate
Set fnFoo = FnFactory.FnCallByName(oTarget, "CallByNameZeroArgReturnObject", VbMethod, True)
Debug.Print fnFoo().Name '<--- with DispID=0 we can pull a default member trick and omit Run
End Sub
Public Sub SubFooZero()
'DO NOT RUN THIS DIRECTLY IT IS HERE TO BE CALLED AS PART OF A TEST
Debug.Print "SubFooZero called"
End Sub
Public Sub SubFooOne(v)
'DO NOT RUN THIS DIRECTLY IT IS HERE TO BE CALLED AS PART OF A TEST
Debug.Print "SubFooOne called with arg " & v
End Sub
Private Sub Test_AsynchronousWebCall_CompactSyntax()
'* run this test to see function delegates in action, this has compact syntax
Static oAsyncXHR As AsynchronousWebCall '<--- needs to (a) static is locally scoped or (b) module or globally scope
Set oAsyncXHR = New AsynchronousWebCall
Call oAsyncXHR.RunAsynchronous("GET", "https://stackoverflow.com/questions/tagged/vba", _
FnFactory.FnAppRun("TestOnError"), _
FnFactory.FnAppRun("TestOnResponseFinished"))
End Sub
Private Sub Test_AsynchronousWebCall_FullerSyntax()
'* run this test to see function delegates in action, this has fuller syntax
Dim fnOnError As FunctionDelegate
Set fnOnError = FnFactory.FnAppRun("TestOnError")
Dim fnOnResponseFinished As FunctionDelegate
Set fnOnResponseFinished = FnFactory.FnAppRun("TestOnResponseFinished")
Static oAsyncXHR As AsynchronousWebCall '<--- needs to (a) static is locally scoped or (b) module or globally scope
Set oAsyncXHR = New AsynchronousWebCall
Call oAsyncXHR.RunAsynchronous("GET", "https://stackoverflow.com/questions/tagged/vba", fnOnError, fnOnResponseFinished)
End Sub
The AsynchronousWebCall class
A more real world use case where we call a web site and pass delegates to functions to be called on error and on completion
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "AsynchronousWebCall"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'* Tools->References
'* WinHttp Microsoft WinHTTP Services, version 5.1 C:WINDOWSsystem32winhttpcom.dll
Private WithEvents moXHR As WinHttp.WinHttpRequest
Attribute moXHR.VB_VarHelpID = -1
Private mfnFunctionDelegateOnError As FunctionDelegate
Private mfnFunctionDelegateOnResponseFinished As FunctionDelegate
'---------------------------------------------------------------------------------------
' Procedure : RunAsynchronous
' DateTime : 06/02/2018 16:20
' Author : Simon
' Purpose :
'---------------------------------------------------------------------------------------
' Arguments :
' sHttpMethod : one of {GET, PUT, POST, DELETE}
' sURL : the web address
' fnOnErrorDelegate : the delegate of the function we want to call on an error
' fnOnResponseFinishedDelegate : the delegate of the function we want to call on completion
'
Public Sub RunAsynchronous(ByVal sHttpMethod As String, ByVal sURL As String, _
ByVal fnOnErrorDelegate As FunctionDelegate, ByVal fnOnResponseFinishedDelegate As FunctionDelegate)
Set mfnFunctionDelegateOnError = fnOnErrorDelegate
Set mfnFunctionDelegateOnResponseFinished = fnOnResponseFinishedDelegate
Set moXHR = New WinHttp.WinHttpRequest
moXHR.Open sHttpMethod, sURL, True
moXHR.send
End Sub
'---------------------------------------------------------------------------------------
' Procedure : moXHR_OnError
' DateTime : 06/02/2018 16:16
' Author : Simon
' Purpose : see https://msdn.microsoft.com/en-us/library/windows/desktop/aa383929(v=vs.85).aspx
'---------------------------------------------------------------------------------------
'
Private Sub moXHR_OnError(ByVal ErrorNumber As Long, ByVal ErrorDescription As String)
'Debug.Print "moXHR_OnError"
If Not mfnFunctionDelegateOnError Is Nothing Then
mfnFunctionDelegateOnError.Run ErrorNumber, ErrorDescription
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : moXHR_OnResponseDataAvailable
' DateTime : 06/02/2018 16:16
' Author : Simon
' Purpose : see https://msdn.microsoft.com/en-us/library/windows/desktop/aa383941(v=vs.85).aspx
'---------------------------------------------------------------------------------------
'
Private Sub moXHR_OnResponseDataAvailable(Data() As Byte)
'Debug.Print "moXHR_OnResponseDataAvailable"
'* not interested
End Sub
'---------------------------------------------------------------------------------------
' Procedure : moXHR_OnResponseFinished
' DateTime : 06/02/2018 16:17
' Author : Simon
' Purpose : see https://msdn.microsoft.com/en-us/library/windows/desktop/aa383946(v=vs.85).aspx
'---------------------------------------------------------------------------------------
'
Private Sub moXHR_OnResponseFinished()
'Debug.Print "moXHR_OnResponseFinished"
If Not mfnFunctionDelegateOnResponseFinished Is Nothing Then
mfnFunctionDelegateOnResponseFinished.Run moXHR.responseText
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : moXHR_OnResponseStart
' DateTime : 06/02/2018 16:17
' Author : Simon
' Purpose : see https://msdn.microsoft.com/en-us/library/windows/desktop/aa383954(v=vs.85).aspx
'---------------------------------------------------------------------------------------
'
Private Sub moXHR_OnResponseStart(ByVal Status As Long, ByVal ContentType As String)
'Debug.Print "moXHR_OnResponseStart"
'* not interested
End Sub
No comments:
Post a Comment