web-dev-qa-db-ja.com

実行時にプロシージャまたは関数名を取得する方法は？

any関数またはプロシージャの名前を返す方法はありますか実行時？

私は現在、このようなものを処理中にエラーが発生しています：

Sub foo()
Const proc_name as string = "foo"
On Error GoTo ErrHandler

    ' do stuff

ExitSub:
    Exit Sub
ErrHandler:
    ErrModule.ShowMessageBox "ModuleName",proc_name
    Resume ExitSub
End Sub

私は最近、定数名ではなく関数名を更新した後、自分の定数の1つが嘘をついているのを経験しました。プロシージャの名前をエラーハンドラに返します。

私はそれを見つけるためにVBIDE.CodeModuleオブジェクトと対話する必要があることを知っています。 Microsoft Visual Basic for Applications Extensibilityライブラリを使用してメタプログラミングを少し行いましたが、実行時にこれを行うことに成功していません。私は以前の試みを持っていません、そしてこれをもう一度試すために私のかかとを掘る前に、私はそれがリモートでさえ可能かどうか知りたいです。

機能しないもの

  1. 組み込みのVBAライブラリを使用して呼び出しスタックにアクセスします。存在しません。
  2. 各配列に入ったり出たりするときに、配列からプロシージャ名をプッシュおよびポップして、独自の呼び出しスタックを実装します。これには、文字列としてproc名をどこかに渡す必要があります。
  3. vbWatchDog のようなサードパーティツール。これはdoes動作しますが、このプロジェクトにサードパーティのツールを使用することはできません。

注

vbWatchdogは、API呼び出しを介してカーネルメモリに直接アクセスすることでこれを行うようです。

vbaerror-handling
16
RubberDuck

これがどれほど役立つかはよくわかりません...

良いことは、サブ/関数名を心配する必要がないことです-あなたはそれを自由に変更できます。気にする必要があるのは、エラーハンドララベル名の一意性だけです。

例えば

エラーハンドララベルの重複を避ける異なるサブ/関数でできる場合

⇩⇩⇩⇩⇩しないでください

Sub Main()
    On Error GoTo ErrHandler
    Debug.Print 1 / 0

ErrHandler:
    Debug.Print "handling error in Main"
    SubMain
End Sub

Sub SubMain()
    On Error GoTo ErrHandler
    Debug.Print 1 / 0

ErrHandler:
    Debug.Print "handling error in SubMain"
End Sub

次に、以下のコードshouldが動作します。

注：完全にテストすることはできませんでしたが、助けがあれば調整して動作させることができると確信しています。

注：VBEの[ツール]-> [参照]を使用して、Visual Basic for Applications Extensibility 5.3への参照を追加します。

Sub Main()

    ' additionally, this is what else you should do:
    ' write a Boolean function that checks if there are no duplicate error handler labels
    ' this will ensure you don't get a wrong sub/fn name returned

    Foo
    Boo

End Sub


Function Foo()

    ' remember to set the label name (handlerLabel) in the handler
    ' each handler label should be unique to avoid errors
    On Error GoTo FooErr
    Cells(0, 1) = vbNullString ' cause error deliberately

FooErr:

    Dim handlerLabel$
    handlerLabel = "FooErr" ' or don't dim this and pass the errHandler name directly to the GetFnOrSubName function

    Debug.Print "Error occured in " & Application.VBE.ActiveCodePane.CodeModule.Name & ": " & GetFnOrSubName(handlerLabel)

End Function


Sub Boo()

    On Error GoTo BooErr
    Cells(0, 1) = vbNullString ' cause error deliberately

BooErr:

    Debug.Print "Error occured in " & Application.VBE.ActiveCodePane.CodeModule.Name & ": " & GetFnOrSubName("BooErr")

End Sub

' returns CodeModule reference needed in the GetFnOrSubName fn
Private Function GetCodeModule(codeModuleName As String) As VBIDE.CodeModule
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent

    Set VBProj = ThisWorkbook.VBProject
    Set VBComp = VBProj.VBComponents(codeModuleName)

    Set GetCodeModule = VBComp.CodeModule
End Function

' returns the name of the sub where the error occured
Private Function GetFnOrSubName$(handlerLabel$)

    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule

    Set VBProj = ThisWorkbook.VBProject
    Set VBComp = VBProj.VBComponents(Application.VBE.ActiveCodePane.CodeModule.Name)
    Set CodeMod = VBComp.CodeModule

    Dim code$
    code = CodeMod.Lines(1, CodeMod.CountOfLines)

    Dim handlerAt&
    handlerAt = InStr(1, code, handlerLabel, vbTextCompare)

    If handlerAt Then

        Dim isFunction&
        Dim isSub&

        isFunction = InStrRev(Mid$(code, 1, handlerAt), "Function", -1, vbTextCompare)
        isSub = InStrRev(Mid$(code, 1, handlerAt), "Sub", -1, vbTextCompare)

        If isFunction > isSub Then
            ' it's a function
            GetFnOrSubName = Split(Mid$(code, isFunction, 40), "(")(0)
        Else
            ' it's a sub
            GetFnOrSubName = Split(Mid$(code, isSub, 40), "(")(0)
        End If

    End If

End Function
6
user2140173

シングルトンにラップされたリンクノードベースのスタッククラスを使用し、グローバルにインスタンス化されます（属性を介して実行されます）CallStackクラス。 David Zemensが提案するようにエラー処理を実行できます（毎回プロシージャ名を保存します）：

Public Sub SomeFunc()
    On Error Goto ErrHandler
    CallStack.Push "MyClass.SomeFunc"


    '... some code ...

    CallStack.Pop()
    Exit Sub

ErrHandler:
    'Use some Ifs or a Select Case to handle expected errors
    GlobalErrHandler() 'Make a global error handler that logs the entire callstack to a file/the immediate window/a table in Access.

End Sub

ディスカッションに役立つ場合は、関連するコードを投稿できます。 CallStackクラスには、最後に呼び出された関数が何であるかを調べるPeekメソッドと、スタック全体の文字列出力を取得するStackTrace関数があります。

より具体的には、VBA拡張機能を使用してボイラープレートエラー処理コード（上記）を自動的に追加することに常に興味があります。実際にやってみたことは一度もありませんが、可能だと思います。

4
Blackhawk

以下は私の質問に正確に答えるわけではありませんが、私の問題を解決します。アプリケーションを公開する前に、開発中に実行する必要があります。

私の回避策は、開発中にプロシージャに定数を挿入するために CPearsonのコード を使用しているため、すべての定数に同じ名前が付けられているという事実に依存しています。

VBIDEライブラリはプロシージャを十分にサポートしていないため、vbeProcedureという名前のクラスモジュールにまとめました。

' Class: vbeProcedure
' requires Microsoft Visual Basic for Applications Extensibility 5.3 library
' Author: Christopher J. McClellan
' Creative Commons Share Alike and Attribute license
'   http://creativecommons.org/licenses/by-sa/3.0/

Option Compare Database
Option Explicit

Private Const vbeProcedureError As Long = 3500

Private mParentModule As CodeModule
Private isParentModSet As Boolean
Private mName As String
Private isNameSet As Boolean

Public Property Get Name() As String
    If isNameSet Then
        Name = mName
    Else
        RaiseObjectNotIntializedError
    End If
End Property

Public Property Let Name(ByVal vNewValue As String)
    If Not isNameSet Then
        mName = vNewValue
        isNameSet = True
    Else
        RaiseReadOnlyPropertyError
    End If
End Property

Public Property Get ParentModule() As CodeModule
    If isParentModSet Then
        Set ParentModule = mParentModule
    Else
        RaiseObjectNotIntializedError
    End If
End Property

Public Property Let ParentModule(ByRef vNewValue As CodeModule)
    If Not isParentModSet Then
        Set mParentModule = vNewValue
        isParentModSet = True
    Else
        RaiseReadOnlyPropertyError
    End If
End Property

Public Property Get StartLine() As Long
    If isParentModSet And isNameSet Then
        StartLine = Me.ParentModule.ProcStartLine(Me.Name, vbext_pk_Proc)
    Else
        RaiseObjectNotIntializedError
    End If
End Property

Public Property Get EndLine() As Long
    If isParentModSet And isNameSet Then
        EndLine = Me.StartLine + Me.CountOfLines
    Else
        RaiseObjectNotIntializedError
    End If
End Property

Public Property Get CountOfLines() As Long
    If isParentModSet And isNameSet Then
        CountOfLines = Me.ParentModule.ProcCountLines(Me.Name, vbext_pk_Proc)
    Else
        RaiseObjectNotIntializedError
    End If
End Property

Public Sub initialize(Name As String, codeMod As CodeModule)
    Me.Name = Name
    Me.ParentModule = codeMod
End Sub

Public Property Get Lines() As String
    If isParentModSet And isNameSet Then
        Lines = Me.ParentModule.Lines(Me.StartLine, Me.CountOfLines)
    Else
        RaiseObjectNotIntializedError
    End If
End Property

Private Sub RaiseObjectNotIntializedError()
    Err.Raise vbObjectError + vbeProcedureError + 10, CurrentProject.Name & "." & TypeName(Me), "Object Not Initialized"
End Sub

Private Sub RaiseReadOnlyPropertyError()
    Err.Raise vbObjectError + vbeProcedureError + 20, CurrentProject.Name & "." & TypeName(Me), "Property is Read-Only after initialization"
End Sub

次に、DevUtilitiesモジュールに関数を追加し（後で重要）、vbeProcedureオブジェクトを作成し、それらのコレクションを返します。

Private Function getProcedures(codeMod As CodeModule) As Collection
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'    Returns collection of all vbeProcedures in a CodeModule      '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim StartLine As Long
    Dim ProcName As String
    Dim lastProcName As String
    Dim procs As New Collection
    Dim proc As vbeProcedure

    Dim i As Long

    ' Skip past any Option statement
    '   and any module-level variable declations.
    StartLine = codeMod.CountOfDeclarationLines + 1

    For i = StartLine To codeMod.CountOfLines
        ' get procedure name
        ProcName = codeMod.ProcOfLine(i, vbext_pk_Proc)
        If Not ProcName = lastProcName Then
            ' create new procedure object
            Set proc = New vbeProcedure
            proc.initialize ProcName, codeMod
            ' add it to collection
            procs.Add proc
            ' reset lastProcName
            lastProcName = ProcName
        End If
    Next i
    Set getProcedures = procs

End Function

次に、特定のコードモジュール内の各プロシージャをループします。

Private Sub fixProcNameConstants(codeMod As CodeModule)
    Dim procs As Collection
    Dim proc As vbeProcedure
    Dim i As Long 'line counter

    'getProcName codeMod
    Set procs = getProcedures(codeMod)

    For Each proc In procs
        With proc
            ' skip the proc.StartLine
            For i = .StartLine + 1 To .EndLine
                ' find constant PROC_NAME declaration
                If InStr(1, .ParentModule.Lines(i, 1), "Const PROC_NAME", vbTextCompare) Then
                    'Debug.Print .ParentModule.Lines(i, 1)
                    ' replace this whole line of code with the correct declaration
                    .ParentModule.ReplaceLine i, "Const PROC_NAME As String = " & Chr(34) & .Name & Chr(34)
                    'Debug.Print .ParentModule.Lines(i, 1)
                    Exit For
                End If
            Next i
        End With
    Next proc
End Sub

最後に、アクティブなプロジェクトのコードモジュールごとにそのサブルーチンを呼び出します（「DevUtilities」モジュールでない限り）。

Public Sub FixAllProcNameConstants()
    Dim prj As vbProject
    Set prj = VBE.ActiveVBProject
    Dim codeMod As CodeModule
    Dim vbComp As VBComponent

    For Each vbComp In prj.VBComponents
        Set codeMod = vbComp.CodeModule
        ' don't mess with the module that'c calling this
        If Not codeMod.Name = "DevUtilities" Then
            fixProcNameConstants codeMod
        End If
    Next vbComp
End Sub

Vba呼び出しスタックを公開するためにvbWatchDogがどのような種類のソーサリーを使用しているのかを見つけたら、また戻ってきます。

3
RubberDuck

Err.Raiseを使用する

Sourceパラメーターを渡すには：

Me.Name & "." & Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
1
Mark Ronollo