Question

有没有办法从函数中以编程方式获取函数参数列表，而不是通过名称显式访问所有参数？

所以对于这个函数签名：

Function doSomething(Arg1 as String, Arg2 as Range, Optional Arg3 as String):

理想情况下，

是否包含参数名称及其元数据（类型，可选，默认值等）？例如，此函数中的代码Me.Arguments将生成如下字典：

{
  "Arg1": {
    "Type": String,
    "Optional": False,
    "Default": Nothing
  },
  "Arg2": {
    "Type": Range,
    "Optional": False,
    "Default": Nothing
  },
  "Arg1": {
    "Type": String,
    "Optional": True,
    "Default": Nothing
  }
}

感谢。

Answer 1

可以使用它吗？

ThisWorkbook.VBProject.VBComponents("[Your_Code_Module_Name]").CodeModule

...并从那里获取方法签名和参数？类似于以下示例中的内容（仅作为示例）。

对于您来说，可能只有 vbext_ProcKind.vbext_pk_Proc = 0 才有用，但在示例中是所有可用的proc类型。

标准模块'Module1'：

' Add referemce to Microsoft Scripting Runtime (Scripting.Dictionary)

Sub main()
    Call doSomething("hello", Nothing)
End Sub

' the code Me.Arguments inside this function would produce a dictionary
Function doSomething(Arg1 As String, _
    Arg2 As Range, Optional Arg3 As Long = 123456789)

    Dim thisCodeArguments As Scripting.Dictionary
    Dim thisCodeModule As Variant
    Set thisCodeModule = ThisWorkbook.VBProject.VBComponents("Module1").CodeModule

    With New ThisCode
        Set thisCodeArguments = .Arguments(thisCodeModule, "doSomething", 0)  ' 0 = VBIDE.vbext_ProcKind.vbext_pk_Proc
        Set thisCodeArguments = .Arguments(thisCodeModule, "someProperty", 3) ' 3 = VBIDE.vbext_ProcKind.vbext_pk_Get
        Set thisCodeArguments = .Arguments(thisCodeModule, "someProperty", 1) ' 1 = VBIDE.vbext_ProcKind.vbext_pk_Let
        Set thisCodeArguments = .Arguments(thisCodeModule, "someProperty", 2) ' 2 = VBIDE.vbext_ProcKind.vbext_pk_Set
    End With

End Function

Public Property Get someProperty() As Variant

End Property

Public Property Let someProperty(ByVal vNewValue As Variant)

End Property

Public Property Set someProperty(ByVal vNewValue As Variant)

End Property

课程模块'ThisCode'：

Public Function Arguments( _
    targetCodeModule As Variant, _
    procedureName As String, _
    vbextProcKind As Integer) _
    As Scripting.Dictionary

    Dim startLine As Long
    Dim countLines As Long
    Dim code As String
    Dim leftParentheses As Long
    Dim rightParentheses As Long
    Dim argumentsText As String
    Dim argumentsArray() As String
    Dim argumentParts() As String
    Dim argumentName As String

    Set Arguments = New Scripting.Dictionary

    With targetCodeModule
        startLine = .ProcStartLine(procedureName, vbextProcKind)
        countLines = .ProcCountLines(procedureName, vbextProcKind)
        code = .Lines(startLine, countLines)
    End With

    leftParentheses = InStr(code, "(")
    If leftParentheses > 0 Then
        rightParentheses = InStr(leftParentheses + 1, code, ")")
    Else
        Err.Raise 123, , "No left parentheses found" ' TODO: error number
    End If

    If rightParentheses > 0 Then
        argumentsText = Trim(Mid(code, leftParentheses + 1, _
                                rightParentheses - leftParentheses - 1))
    Else
        Err.Raise 456, , "No right parentheses found" ' TODO: error number
    End If

    If Len(argumentsText) = 0 Then Exit Function
    argumentsText = Replace(argumentsText, "_", "")
    argumentsText = Replace(argumentsText, vbCrLf, "")

    argumentsArray = Split(argumentsText, ",")

    Dim i As Long
    Dim j As Long
    Dim argumentInfo As Argument
    Dim argumentArray() As String

    For i = LBound(argumentsArray) To UBound(argumentsArray)

        Set argumentInfo = New Argument
        Set argumentInfo.DefaultValue = Nothing
        argumentInfo.IsOptional = False
        argumentInfo.TypeName = ""

        argumentParts = Split(argumentsArray(i))

        For j = LBound(argumentParts) To UBound(argumentParts)
            If Len(Trim(argumentParts(j))) = 0 Then GoTo continue
            If Trim(argumentParts(j)) = "Optional" Then
                argumentInfo.IsOptional = True
                argumentName = Trim(argumentParts(j + 1))
            ElseIf Trim(argumentParts(j)) = "As" Then
                argumentName = Trim(argumentParts(j - 1))
                argumentInfo.TypeName = Trim(argumentParts(j + 1))
            ElseIf Trim(argumentParts(j)) = "=" Then
                argumentInfo.DefaultValue = CVar(argumentParts(j + 1))
            End If
continue:
        Next j

        Arguments.Add argumentName, argumentInfo
    Next i

End Function

课程模块'参数'：

Public TypeName As String
Public IsOptional As Boolean
Public DefaultValue As Variant

<强>词典： enter image description here

Answer 2

您可以考虑

使用Application.Caller获取对包含公式的单元格的引用，然后使用该单元格的.Formula属性将公式作为文本。
然后，您可以解析公式以将参数作为文本。

当我想将3D范围作为参数传递给UDF时，我这样做了（所以我可以制作一套像COUNTIF和SUMIF这样的函数来处理像Sheet1:Sheet99!$A$1:$A$1000这样的3D范围{1}}）。我发现当3D范围中的值发生变化时会触发UDF - 但是一旦我需要对UDF中接收到3D范围的Variant做任何事情，UDF就会产生运行时错误。我的解决方法如第一段所述 - 获取公式并解析它以将3D范围作为文本。

我尝试将代码作为块插入，但是因格式化要求而受阻。以下是在my SkyDrive

上使用它的工作簿

Answer 3

很棒的问题！

我不这么认为......我最接近的是使用此解决方法在FunctionWizard中使用公式预填充ActiveCell（下面的代码使用第一个可用的代码）空白单元格查询）使用NPV调用函数对话框。

我尝试将参数传递给同一个对话框但没有成功。

Sub Kludge()
Dim rng1 As Range
Set rng1 = Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
With rng1
Application.Goto rng1
.Value = "=NPV(10%,-10,5,5,5)"
c = Application.Dialogs(xlDialogFunctionWizard).Show 
.ClearContents
End With

enter image description here

Answer 4

您可以使用Typestring获取已注册函数的Application.RegisteredFunctions。 typestring为您提供每个参数的数据类型以及该函数是否为多线程和/或volatile。

但它只适用于XLL - 已注册的函数，而不是VBA或Automation函数，您还需要做一些技巧来匹配函数的名称和typestring

请参阅my blog post

我可以在VBA中以编程方式检查Excel函数签名吗？

4 个答案: