Application.Run with Error Trapping

Question

In Access, using VBA, I want to use Application.Run and trap any errors. Unfortunately, Application.Run seems to hijack error trapping. Is there a way to fix this?

On Error Resume Next
Application.Run ...

I never get past Application.Run on an error, even if I specify On Error Resume Next or On Error GoTo ErrCatch. My error trapping setting is ignored.

Answer 1

If the procedure you're calling is inside your VBA project, then you can just call the procedure directly with:

Sub Foo()
   'Application.Run "SomeProc"
   SomeProc
End Sub

If you need to be able to call things dynamically by name, you could explore using classes and CallByName:

'In a standard module
Sub Foo()
   Dim o as New ProcRunner
   CallByName o, "SomeProc", VbMethod, args
End Sub

'In a class module called ProcRunner
Sub SomeProc()
   DoSomethingHere
   'Or, do something in a standard module
   Module1.SomeOtherProc
End Sub

Or, you could write your own dynamic handler, along the lines of:

Sub AppRun(ProcName As String, ParamArray Args)
  Select Case ProcName
    Case "SomeProc"
        SomeProc
    Case "SomeFunc"
        SomeFunc
  End Select
End Sub

If you're calling procedures in another VBA project, you may need to add a reference to that project, depending upon the VBA host.

However, if you're using Application.Run because you're calling functions registered by a DLL or XLL, then you don't have any option other than to use Application.Run

Answer 2

Workaround for certain Use-Cases of Application.Run

Important: This workaround only works if the arguments are passed via the parameters Application.Run provides. If the arguments are passed as part of the macro name string, no errors can be trapped!
E.g. For this workaround, :

1. this syntax works: Application.Run "ProcToCall", arg
2. this syntax doesn't work: Application.Run "ProcToCall(" & arg & ")"

If the reason for the Application.Run usage is to call a procedure from a different Workbook, and you have access to the code in that Workbook, I have found a decent workaround.

In the following, I will present a minimal example to illustrate how it works.

Say you want to call the Sub ActualProcToBeCalled() using Application.Run(). Because this prevents error trapping, we instead call ErrorForwardingHelperProc, which in turn calls ActualProcToBeCalled() normally. The problem is that usually, this will lead to loss of error information when Application.Run() returns, however, this can be prevented with a weird hack as demonstrated in the following:

Option Explicit

Sub WorkaroundDemo()
    On Error Resume Next
    Application.Run "ErrorForwardingHelperProc"
    Debug.Print Err.Number
End Sub

Sub ErrorForwardingHelperProc()
    On Error GoTo ForwardError
    
    ActualProcToBeCalled
    
    Exit Sub
ForwardError:
    'This weird hack prevents the error information from getting lost when
    'Application.Run returns:
    Dim errNumber As Long:        errNumber = Err.Number
    Dim errSource As String:      errSource = Err.Source
    Dim errDescription As String: errDescription = Err.description
    On Error GoTo -1
    Err.Number = errNumber
    Err.Source = errSource
    Err.description = errDescription
End Sub

Sub ActualProcToBeCalled()
    Err.Raise 1
End Sub

^{Note that this example uses Subs, but the principle works the same with Functions.}

Obviously, if ActualProcToBeCalled resides in a different Workbook than WorkaroundDemo, this workaround requires ErrorForwardingHelperProc to be in that other Workbook too, so if it is not already there, control over the code in that other Workbook is required.

This setup can be done manually, which should usually not be an issue while developing a project that involves multiple Workbooks with code interacting with each other.

Drop-in Replacement for Application.Run that allows Error Trapping

If Trust access to the VBA project object model is enabled, this entire setup can be done automatically by the calling code. Unfortunately, copying the exact behavior of the native Application.Run requires quite a bit of parsing in the VBA project of the target procedure. Also, setting it up requires the insertion and removal (cleanup) of a module and some code, so this custom procedure is therefore much, much slower than the native Application.Run.

^{Note that this slowness only applies to the drop-in replacement discussed in this chapter, the manual setup method explained in the minimal example is just as fast as the native Application.Run.}

When calling a procedure from a small project, the runtime of the drop-in replacement presented here should be around 100ms, compared to ~0.3ms (independent of project size) for the native Application.Run.

If it is only called a few times this should not be an issue, except if calling a procedure in a very large VBA project (100 000+ lines of code), then it can become very slow, and manual setup as explained in the minimal example will work much better.

The code in the following drop-in replacement for Application.Run aims to behave exactly like the inbuilt Application.Run except that it traps potential errors and re-raises them if any have occurred:

'Drop-in replacement for 'Application.Run' that enables error trapping in the
'called procedure. Requires 'Trust access to the VBA project object model'
'This procedure can be very slow if the VBA project containing the called
'procedure is very large. Otherwise, this procedure is still slow (~100ms).
'More information: https://stackoverflow.com/a/77416358/12287457
'Author: Guido Witt-Dörring
Function ApplicationRun(ByVal Macro As String, Optional ByRef arg1 As Variant, _
               Optional ByRef arg2 As Variant, Optional ByRef arg3 As Variant, _
               Optional ByRef arg4 As Variant, Optional ByRef arg5 As Variant, _
               Optional ByRef arg6 As Variant, Optional ByRef arg7 As Variant, _
               Optional ByRef arg8 As Variant, Optional ByRef arg9 As Variant, _
             Optional ByRef arg10 As Variant, Optional ByRef arg11 As Variant, _
             Optional ByRef arg12 As Variant, Optional ByRef arg13 As Variant, _
             Optional ByRef arg14 As Variant, Optional ByRef arg15 As Variant, _
             Optional ByRef arg16 As Variant, Optional ByRef arg17 As Variant, _
             Optional ByRef arg18 As Variant, Optional ByRef arg19 As Variant, _
             Optional ByRef arg20 As Variant, Optional ByRef arg21 As Variant, _
             Optional ByRef arg22 As Variant, Optional ByRef arg23 As Variant, _
             Optional ByRef arg24 As Variant, Optional ByRef arg25 As Variant, _
             Optional ByRef arg26 As Variant, Optional ByRef arg27 As Variant, _
             Optional ByRef arg28 As Variant, Optional ByRef arg29 As Variant) _
                        As Variant
    Const methodName As String = "ApplicationRun"
    Const vbErrArgumentNotOptional As Long = 449
    Const vbErrWrongNumberOfArguments As Long = 450
    Dim macroNotFoundErrMsg As String
    macroNotFoundErrMsg = "Cannot run the macro """ & Macro & """. " & _
            "The macro may not be available in this workbook or all macros " & _
            "may be disabled."
    
    If Macro Like "*(*)*" Then 'MacroName includes the arguments,
        'in this case we can't do anything to catch the errors. Also, extra
        'arguments passed to Application.Run are ignored anyways in this case...
        ApplicationRun = Application.Run(Macro)
        Exit Function
    End If
    
    'Raise the same error as Application.Run if input is too long:
    If Len(Macro) > 255 Then Application.Run Space(256)
    
    'Parse inputs
    Dim wbName As String, wbNameInputWasInQuotes As Boolean
    If Macro Like "*!*" Then wbName = Left(Macro, InStr(1, Macro, "!") - 1)
    If wbName = vbNullString Then _
        wbName = "'" & Replace(ThisWorkbook.Name, "'", "''") & "'"
    wbNameInputWasInQuotes = (wbName Like "'*'")
    If wbNameInputWasInQuotes Then
        wbName = Replace(Mid(wbName, 2, Len(wbName) - 2), "''", "'")
    ElseIf wbName Like "*'*" Then
        Err.Raise 1004, methodName, macroNotFoundErrMsg
    End If

    On Error Resume Next
    Dim wb As Object
    Set wb = Application.Workbooks(wbName)
    If Err.Number <> 0 Then
        On Error GoTo 0
        'Try to open workbook, just like Application.Run would:
        Set wb = Application.Workbooks.Open(wbName)
    End If
    On Error GoTo 0
    
    Dim macroName As String: macroName = Mid(Macro, InStrRev(Macro, "!") + 1)
    Dim moduleName As String
    Dim vbaProjectName As String
    
    If macroName = "" Then Err.Raise 5, methodName, "Invalid Macro String."
    
    Dim parts() As String: parts = Split(macroName, ".")
    
    If UBound(parts) > 2 Then
        Err.Raise 5, methodName, "Invalid Macro String."
    ElseIf UBound(parts) = 2 Then
        macroName = parts(2)
        moduleName = parts(1)
        vbaProjectName = parts(0)
    ElseIf UBound(parts) = 1 Then
        macroName = parts(1)
        moduleName = parts(0)
    Else
        macroName = parts(0)
    End If
    
    Dim actProcName As String: actProcName = macroName
    If moduleName <> "" Then actProcName = moduleName & "." & actProcName
    If vbaProjectName <> "" Then actProcName = vbaProjectName & "." & actProcName

    'Get VBProject of procedure to be called:
    Dim vbProj As Object: Set vbProj = wb.VBProject
    
    If vbaProjectName <> vbNullString Then
        If vbProj.Name <> vbaProjectName Then
            Err.Raise 1004, methodName, macroNotFoundErrMsg
        End If
    End If
    
    'Find procedure to be called.
    'To mimic Application.Run behaviour we need to know if it is a Sub or a
    'Function and also how many (optional) parameters the procedure has,
    'because Application.Run throws a runtime error if the call doesn't match
    'the signature, not a compile error like a regular function call would.
    Dim vbComp As Object
    Dim codeMod As Object
    Dim procName As String
    Dim procKind As Long
    Dim lineNum As Long
    Dim isSub As Boolean, wasFound As Boolean

    ' Iterate through each component in the project
    Dim codeModProcNameColl As Collection

    For Each vbComp In vbProj.VBComponents
        If moduleName <> vbNullString Then
            If moduleName <> vbComp.Name Then GoTo NextComp
        End If
        DoEvents
        'Debug.Print vbComp.Name
        Set codeMod = vbComp.CodeModule
        Set codeModProcNameColl = New Collection

        lineNum = 1
        Do While lineNum < codeMod.CountOfLines
            'Get the name of the procedure at the given line number
            procName = codeMod.ProcOfLine(lineNum, procKind)
            If procName <> "" Then
                If procName = macroName Then
                    'Doesnt seem to work, but we'll do it later with a different
                    'method, this statement is left here for fotore research:
                    '(0 = VBIDE.vbext_ProcKind.vbext_pk_Proc)
                    isSub = IIf(procKind = 0, True, False)
                    wasFound = True
                    Dim numArgs As Long
                    Dim numOptional As Long
                    Dim hasParamArray As Boolean
                    Dim procSig As String
                    Dim procLines() As String
                    Dim procHasStarted As Boolean
                    Dim line As Variant
                    Dim subPos As Integer
                    Dim funcPos As Integer
                    Dim aposPos As Integer
                    Dim remPos As Integer
                    Dim procPos As Integer
                    Dim commPos As Integer
                    procLines = Split(Replace(codeMod.lines(lineNum, _
                        codeMod.CountOfLines - lineNum + 2), vbCrLf, vbLf), vbLf)
                    For Each line In procLines
                        If Not procHasStarted Then
                            'Check if line is comment or empty
                            subPos = InStr(1, line, "Sub", vbTextCompare)
                            funcPos = InStr(1, line, "Function", vbTextCompare)
                            aposPos = InStr(1, line, "'", vbBinaryCompare)
                            remPos = InStr(1, line, "Rem", vbTextCompare)
                            If subPos <> 0 Then procPos = subPos _
                                           Else procPos = funcPos
                            If funcPos <> 0 And funcPos < procPos Then _
                                procPos = funcPos
                            If aposPos <> 0 Then commPos = aposPos _
                                            Else commPos = remPos
                            If remPos <> 0 And remPos < commPos Then _
                                commPos = remPos
                            If procPos <> 0 Then
                                If commPos = 0 Or (procPos < commPos) Then _
                                    procHasStarted = True
                            End If
                            procPos = 0
                            commPos = 0
                        End If
                        If procHasStarted Then
                            If InStr(1, line, ")", vbBinaryCompare) = 0 Then
                                'Don't remove " ", it's important for correct
                                'parsing of " Optional "
                                procSig = procSig & " " & line
                            Else
                                procSig = procSig & " " & Left(line, _
                                       InStr(1, line, ")", vbBinaryCompare) - 1)
                                Exit For
                            End If
                        End If
                    Next line
                    isSub = IIf(InStr(1, " " & procSig, " Sub ", _
                                      vbTextCompare) = 0, _
                              False, True)
                    procSig = Replace(procSig, "(", "( ") 'Important for parsing
                    procSig = Mid(procSig, InStr(1, procSig, "(", _
                                                 vbBinaryCompare) + 1)
                    numOptional = (Len(procSig) - _
                                  Len(Replace(procSig, " Optional ", ""))) \ 10
                    numArgs = Len(procSig) - Len(Replace(procSig, ",", "")) + 1
                    hasParamArray = InStr(1, procSig, "ParamArray", _
                                          vbTextCompare) <> 0
                    If numArgs = 1 Then
                        If Len(Replace(Replace(Replace(procSig, "_", ""), _
                                                  " ", ""), vbTab, "")) = 0 Then
                            numArgs = 0
                        End If
                    End If
                    Exit For
                End If
                On Error Resume Next
                codeModProcNameColl.Add 1, procName
                'Coll is necessary because if a ProcName exists twice, e.g.:
'                #If SomeCompilerDirective Then
'                    Private Function Proc()
'                        '...
'                    End Function
'                #Else
'                    Private Function Proc()
'                        '...
'                    End Function
'                #End If

                'Then codeMod.ProcCountLines can cause the application to crash
                If Err.Number <> 0 Then
                    lineNum = lineNum + 1
                Else
                    'Move to the line after the current procedure
                    lineNum = lineNum + _
                                      codeMod.ProcCountLines(procName, procKind)
                End If
                On Error GoTo 0
            Else
                ' Move to the next line if no procedure name was returned
                lineNum = lineNum + 1
            End If
        Loop
NextComp:
    Next vbComp
    On Error GoTo 0
    
    If Not wasFound Then Err.Raise 1004, methodName, macroNotFoundErrMsg
    
    'Construct args:
    Dim args As String
    If Not IsMissing(arg1) Then args = "arg1, " Else args = ", "
    If Not IsMissing(arg2) Then args = args & "arg2, " Else args = args & ", "
    If Not IsMissing(arg3) Then args = args & "arg3, " Else args = args & ", "
    If Not IsMissing(arg4) Then args = args & "arg4, " Else args = args & ", "
    If Not IsMissing(arg5) Then args = args & "arg5, " Else args = args & ", "
    If Not IsMissing(arg6) Then args = args & "arg6, " Else args = args & ", "
    If Not IsMissing(arg7) Then args = args & "arg7, " Else args = args & ", "
    If Not IsMissing(arg8) Then args = args & "arg8, " Else args = args & ", "
    If Not IsMissing(arg9) Then args = args & "arg9, " Else args = args & ", "
    If Not IsMissing(arg10) Then args = args & "arg10, " Else args = args & ", "
    If Not IsMissing(arg11) Then args = args & "arg11, " Else args = args & ", "
    If Not IsMissing(arg12) Then args = args & "arg12, " Else args = args & ", "
    If Not IsMissing(arg13) Then args = args & "arg13, " Else args = args & ", "
    If Not IsMissing(arg14) Then args = args & "arg14, " Else args = args & ", "
    If Not IsMissing(arg15) Then args = args & "arg15, " Else args = args & ", "
    If Not IsMissing(arg16) Then args = args & "arg16, " Else args = args & ", "
    If Not IsMissing(arg17) Then args = args & "arg17, " Else args = args & ", "
    If Not IsMissing(arg18) Then args = args & "arg18, " Else args = args & ", "
    If Not IsMissing(arg19) Then args = args & "arg19, " Else args = args & ", "
    If Not IsMissing(arg20) Then args = args & "arg20, " Else args = args & ", "
    If Not IsMissing(arg21) Then args = args & "arg21, " Else args = args & ", "
    If Not IsMissing(arg22) Then args = args & "arg22, " Else args = args & ", "
    If Not IsMissing(arg23) Then args = args & "arg23, " Else args = args & ", "
    If Not IsMissing(arg24) Then args = args & "arg24, " Else args = args & ", "
    If Not IsMissing(arg25) Then args = args & "arg25, " Else args = args & ", "
    If Not IsMissing(arg26) Then args = args & "arg26, " Else args = args & ", "
    If Not IsMissing(arg27) Then args = args & "arg27, " Else args = args & ", "
    If Not IsMissing(arg28) Then args = args & "arg28, " Else args = args & ", "
    If Not IsMissing(arg29) Then args = args & "arg29, " Else args = args & ", "
    
    Do Until Right(args, 1) Like "#" Or args = vbNullString
        args = Left(args, Len(args) - 1)
    Loop
    
    'Check if procedure signature matches with passed arguments:
    Dim argsArr() As String: argsArr = Split(args, ", ")
    If numArgs <= UBound(argsArr) And Not hasParamArray Then 'Too many arguments
        Err.Raise vbErrWrongNumberOfArguments
    ElseIf numArgs - numOptional + hasParamArray > UBound(argsArr) + 1 Then
        'Too few arguments
        Err.Raise vbErrArgumentNotOptional
    End If
    
    Dim i As Long
    For i = LBound(argsArr) To numArgs - numOptional + hasParamArray - 1
        If argsArr(i) = vbNullString Then Err.Raise vbErrArgumentNotOptional
    Next i
    
    'Signature matches. Create Helper-macro code...
    Dim s As String
    Const n As String = vbNewLine
    If isSub Then
        s = s & n & "Private Sub Helper(Optional ByRef arg1 As Variant, _"
    Else
        s = s & n & "Private Function Helper(Optional ByRef arg1 As Variant, _"
    End If
    s = s & n & "Optional ByRef arg2 As Variant, Optional ByRef arg3 As Variant, _"
    s = s & n & "Optional ByRef arg4 As Variant, Optional ByRef arg5 As Variant, _"
    s = s & n & "Optional ByRef arg6 As Variant, Optional ByRef arg7 As Variant, _"
    s = s & n & "Optional ByRef arg8 As Variant, Optional ByRef arg9 As Variant, _"
    s = s & n & "Optional ByRef arg10 As Variant, Optional ByRef arg11 As Variant, _"
    s = s & n & "Optional ByRef arg12 As Variant, Optional ByRef arg13 As Variant, _"
    s = s & n & "Optional ByRef arg14 As Variant, Optional ByRef arg15 As Variant, _"
    s = s & n & "Optional ByRef arg16 As Variant, Optional ByRef arg17 As Variant, _"
    s = s & n & "Optional ByRef arg18 As Variant, Optional ByRef arg19 As Variant, _"
    s = s & n & "Optional ByRef arg20 As Variant, Optional ByRef arg21 As Variant, _"
    s = s & n & "Optional ByRef arg22 As Variant, Optional ByRef arg23 As Variant, _"
    s = s & n & "Optional ByRef arg24 As Variant, Optional ByRef arg25 As Variant, _"
    s = s & n & "Optional ByRef arg26 As Variant, Optional ByRef arg27 As Variant, _"
    s = s & n & "Optional ByRef arg28 As Variant, Optional ByRef arg29 As Variant)"
    If Not isSub Then s = s & " _" & n & "         As Variant"
    s = s & n & "    On Error GoTo ForwardError"
    s = s & n & ""
    If isSub Then
        s = s & n & "    " & actProcName & " " & args
        s = s & n & ""
        s = s & n & "    Exit Sub"
    Else
        s = s & n & "    Helper = " & actProcName & "(" & args & ")"
        s = s & n & ""
        s = s & n & "    Exit Function"
    End If
    s = s & n & "ForwardError:"
    s = s & n & "    'This weird hack prevents the error information from"
    s = s & n & "    'getting lost when Application.Run returns:"
    s = s & n & "    Dim errNumber As Long:        errNumber = Err.Number"
    s = s & n & "    Dim errSource As String:      errSource = Err.Source"
    s = s & n & "    Dim errDescription As String: errDescription = Err.description"
    s = s & n & "    On Error GoTo -1"
    s = s & n & "    Err.Number = errNumber"
    s = s & n & "    Err.Source = errSource"
    s = s & n & "    Err.description = errDescription"
    If isSub Then
        s = s & n & "End Sub"
    Else
        s = s & n & "End Function"
    End If
    
    Dim tempVbModule As VBIDE.VBComponent
    Set tempVbModule = vbProj.VBComponents.Add(1) '1 = vbext_ct_StdModule
    
    tempVbModule.CodeModule.InsertLines tempVbModule.CodeModule.CountOfLines, s

    If wbName = ThisWorkbook.Name Then
        wbName = ""
    Else
       'This if statement is there to exactly replicate Application.Run behavior
        If wbNameInputWasInQuotes Then _
            wbName = "'" & Replace(wbName, "'", "''") & "'" & "!"
    End If
    If isSub Then
        Application.Run wbName & tempVbModule.Name & "." & "Helper", _
                                     arg1, arg2, arg3, arg4, arg5, _
                                     arg6, arg7, arg8, arg9, arg10, arg11, _
                                     arg12, arg13, arg14, arg15, arg16, arg17, _
                                     arg18, arg19, arg20, arg21, arg22, arg23, _
                                     arg24, arg25, arg26, arg27, arg28, arg29
    Else
        ApplicationRun = Application.Run(wbName & tempVbModule.Name & "." & _
                                     "Helper", arg1, arg2, arg3, arg4, arg5, _
                                     arg6, arg7, arg8, arg9, arg10, arg11, _
                                     arg12, arg13, arg14, arg15, arg16, arg17, _
                                     arg18, arg19, arg20, arg21, arg22, arg23, _
                                     arg24, arg25, arg26, arg27, arg28, arg29)
    End If
    vbProj.VBComponents.Remove tempVbModule
    If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.description
End Function