如何在VBA中返回传递给它的(变体)变量的维度数

Question

有人知道如何返回一个(变量)变量传递给它在VBA的维度数吗?

Answer 1

Function getDimension(var As Variant) As Long
    On Error GoTo Err
    Dim i As Long
    Dim tmp As Long
    i = 0
    Do While True
        i = i + 1
        tmp = UBound(var, i)
    Loop
Err:
    getDimension = i - 1
End Function

这是我能想到的唯一办法。不是pretty… .

看看MSDN，他们基本上做了同样的事情。

Answer 2

返回不吞食错误的维数:

#If VBA7 Then
  Private Type Pointer: Value As LongPtr: End Type
  Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (ByRef dest As Any, ByRef src As Any, ByVal Size As LongPtr)
#Else
  Private Type Pointer: Value As Long: End Type
  Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByRef dest As Any, ByRef src As Any, ByVal Size As Long)
#End If
Private Type TtagVARIANT
    vt As Integer
    r1 As Integer
    r2 As Integer
    r3 As Integer
    sa As Pointer
End Type

Public Function GetDims(source As Variant) As Integer
    Dim va As TtagVARIANT
    RtlMoveMemory va, source, LenB(va)                                            ' read tagVARIANT              '
    If va.vt And &H2000 Then Else Exit Function                                   ' exit if not an array         '
    If va.vt And &H4000 Then RtlMoveMemory va.sa, ByVal va.sa.Value, LenB(va.sa)  ' read by reference            '
    If va.sa.Value Then RtlMoveMemory GetDims, ByVal va.sa.Value, 2               ' read cDims from tagSAFEARRAY '
End Function

用法:

Sub Examples()
    Dim list1
    Debug.Print GetDims(list1)    ' >> 0  '
    list1 = Array(1, 2, 3, 4)
    Debug.Print GetDims(list1)    ' >> 1  '
    Dim list2()
    Debug.Print GetDims(list2)    ' >> 0  '
    ReDim list2(2)
    Debug.Print GetDims(list2)    ' >> 1  '
    ReDim list2(2, 2)
    Debug.Print GetDims(list2)    ' >> 2  '
    Dim list3(0 To 0, 0 To 0, 0 To 0)
    Debug.Print GetDims(list3)    ' >> 3  '
End Sub

Answer 3

@cularis和@Issun对于所问的确切问题有完全足够的答案。不过，我想对你的问题提出质疑。你真的有一堆未知维数的数组吗?如果你在Excel中工作，唯一会发生这种情况的是UDF，你可能会得到一个一维数组或二维数组(或非数组)，但没有其他。

你几乎不应该有一个期望任意东西的例程。因此，你可能也不应该有一个通用的"查找数组尺寸"例程。

因此，考虑到这一点，以下是我使用的例程:

Global Const ERR_VBA_NONE& = 0
Global Const ERR_VBA_SUBSCRIPT_OUT_OF_RANGE& = 9
'Tests an array to see if it extends to a given dimension
Public Function arrHasDim(arr, dimNum As Long) As Boolean
    Debug.Assert IsArray(arr)
    Debug.Assert dimNum > 0
    'Note that it is possible for a VBA array to have no dimensions (i.e.
    ''LBound' raises an error even on the first dimension). This happens
    'with "unallocated" (borrowing Chip Pearson's terminology; see
    'http://www.cpearson.com/excel/VBAArrays.htm) dynamic arrays -
    'essentially arrays that have been declared with 'Dim arr()' but never
    'sized with 'ReDim', or arrays that have been deallocated with 'Erase'.
    On Error Resume Next
        Dim lb As Long
        lb = LBound(arr, dimNum)
        'No error (0) - array has given dimension
        'Subscript out of range (9) - array doesn't have given dimension
        arrHasDim = (Err.Number = ERR_VBA_NONE)
        Debug.Assert (Err.Number = ERR_VBA_NONE Or Err.Number = ERR_VBA_SUBSCRIPT_OUT_OF_RANGE)
    On Error GoTo 0
End Function
'"vect" = array of one and only one dimension
Public Function isVect(arg) As Boolean
    If IsObject(arg) Then
        Exit Function
    End If
    If Not IsArray(arg) Then
        Exit Function
    End If
    If arrHasDim(arg, 1) Then
        isVect = Not arrHasDim(arg, 2)
    End If
End Function
'"mat" = array of two and only two dimensions
Public Function isMat(arg) As Boolean
    If IsObject(arg) Then
        Exit Function
    End If
    If Not IsArray(arg) Then
        Exit Function
    End If
    If arrHasDim(arg, 2) Then
        isMat = Not arrHasDim(arg, 3)
    End If
End Function

请注意Chip Pearson优秀网站的链接:http://www.cpearson.com/excel/VBAArrays.htm

参见:如何确定一个数组是否在VB6中初始化?我个人不喜欢它所依赖的未记录的行为，并且在我正在编写的Excel VBA代码中，性能很少那么重要，但它仍然很有趣。

Answer 4

对于数组，MS有一个很好的方法，它包括循环直到出现错误。

"这个例程通过测试每个维度的LBound来测试名为Xarray的数组。使用For…下一个循环，例程循环遍历可能的数组维数，最多60000，直到生成错误。然后，错误处理程序执行循环失败的计数器步骤，减去1(因为前一个步骤是最后一个没有错误的步骤)，并在消息框....中显示结果"

http://support.microsoft.com/kb/152288

代码的清理版本(决定作为一个函数，而不是子函数):

Function NumberOfDimensions(ByVal vArray As Variant) As Long
Dim dimnum As Long
On Error GoTo FinalDimension
For dimnum = 1 To 60000
    ErrorCheck = LBound(vArray, dimnum)
Next
FinalDimension:
    NumberOfDimensions = dimnum - 1
End Function

Answer 5

Microsoft已经记录了VARIANT和SAFEARRAY的结构，并且使用它们可以解析二进制数据以获得维度。

创建一个普通代码模块。我称我的为"mdlDims"。你可以通过调用简单的函数'GetDims'并传递给它一个数组来使用它。

Option Compare Database
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (var() As Any) As Long
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221482(v=vs.85).aspx
Private Type SAFEARRAY
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
End Type
'Variants are all 16 bytes, but they are split up differently based on the contained type
'VBA doesn't have the ability to Union, so a Type is limited to representing one layout
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221627(v=vs.85).aspx
Private Type ARRAY_VARIANT
    vt As Integer
    wReserved1 As Integer
    wReserved2 As Integer
    wReserved3 As Integer
    lpSAFEARRAY As Long
    data(4) As Byte
End Type
'http://msdn.microsoft.com/en-us/library/windows/desktop/ms221170(v=vs.85).aspx
Private Enum VARENUM
    VT_EMPTY = &H0
    VT_NULL
    VT_I2
    VT_I4
    VT_R4
    VT_R8
    VT_CY
    VT_DATE
    VT_BSTR
    VT_DISPATCH
    VT_ERROR
    VT_BOOL
    VT_VARIANT
    VT_UNKNOWN
    VT_DECIMAL
    VT_I1 = &H10
    VT_UI1
    VT_UI2
    VT_I8
    VT_UI8
    VT_INT
    VT_VOID
    VT_HRESULT
    VT_PTR
    VT_SAFEARRAY
    VT_CARRAY
    VT_USERDEFINED
    VT_LPSTR
    VT_LPWSTR
    VT_RECORD = &H24
    VT_INT_PTR
    VT_UINT_PTR
    VT_ARRAY = &H2000
    VT_BYREF = &H4000
End Enum
Public Function GetDims(VarSafeArray As Variant) As Integer
    Dim varArray As ARRAY_VARIANT
    Dim lpSAFEARRAY As Long
    Dim sArr As SAFEARRAY
    'Inspect the Variant
    CopyMemory VarPtr(varArray.vt), VarPtr(VarSafeArray), 16&
    'If the Variant is pointing to an array...
    If varArray.vt And (VARENUM.VT_ARRAY Or VARENUM.VT_BYREF) Then
        'Get the pointer to the SAFEARRAY from the Variant
        CopyMemory VarPtr(lpSAFEARRAY), varArray.lpSAFEARRAY, 4&
        'If the pointer is not Null
        If Not lpSAFEARRAY = 0 Then
            'Read the array dimensions from the SAFEARRAY
            CopyMemory VarPtr(sArr), lpSAFEARRAY, LenB(sArr)
            'and return them
            GetDims = sArr.cDims
        Else
            'The array is uninitialized
            GetDims = 0
        End If
    Else
        'Not an array, you could choose to raise an error here
        GetDims = 0
    End If
End Function

Answer 6

我想你的意思是没有使用On Error Resume Next，这是大多数程序员不喜欢的，这也意味着在调试期间你不能使用'Break On All Errors'来让代码停止死亡(Tools->Options->General->Error Trapping->Break On All Errors)。

对我来说，一个解决方案是将任何错误恢复下一个埋葬到编译的DLL中，在过去，这将是VB6。今天你可以使用VB。. NET，但我选择使用c#。

如果你可以使用Visual Studio，那么这里有一些源代码。它将返回一个字典，字典。Count将返回维度数。这些项还将以连接字符串的形式包含LBound和UBound。我总是查询数组不仅要查询它的维度还要查询这些维度的LBound和UBound所以我把它们放在一起在脚本字典

中返回一整束信息

这是c#源代码，启动一个类库叫它BuryVBAErrorsCS，设置ComVisible(true)添加一个引用到COM库'Microsoft Scripting Runtime'，注册互操作。

using Microsoft.VisualBasic;
using System;
using System.Runtime.InteropServices;
namespace BuryVBAErrorsCS
{
    // Requires adding a reference to COM library Microsoft Scripting Runtime
    // In AssemblyInfo.cs set ComVisible(true);
    // In Build tab check 'Register for Interop'
    public interface IDimensionsAndBounds
    {
        Scripting.Dictionary DimsAndBounds(Object v);
    }
    [ClassInterface(ClassInterfaceType.None)]
    [ComDefaultInterface(typeof(IDimensionsAndBounds))]
    public class CDimensionsAndBounds : IDimensionsAndBounds
    {
        public Scripting.Dictionary DimsAndBounds(Object v)
        {
            Scripting.Dictionary dicDimsAndBounds;
            dicDimsAndBounds = new Scripting.Dictionary();
            try
            {
                for (Int32 lDimensionLoop = 1; lDimensionLoop < 30; lDimensionLoop++)
                {
                    long vLBound = Information.LBound((Array)v, lDimensionLoop);
                    long vUBound = Information.UBound((Array)v, lDimensionLoop);
                    string concat = (string)vLBound.ToString() + " " + (string)vUBound.ToString();
                    dicDimsAndBounds.Add(lDimensionLoop, concat);
                }
            }
            catch (Exception)
            {
            }
            return dicDimsAndBounds;
        }
    }
}

对于Excel客户端VBA代码，这里是一些源代码

Sub TestCDimensionsAndBounds()
    '* requires Tools->References->BuryVBAErrorsCS.tlb
    Dim rng As Excel.Range
    Set rng = ThisWorkbook.Worksheets.Item(1).Range("B4:c7")
    Dim v As Variant
    v = rng.Value2
    Dim o As BuryVBAErrorsCS.CDimensionsAndBounds
    Set o = New BuryVBAErrorsCS.CDimensionsAndBounds
    Dim dic As Scripting.Dictionary
    Set dic = o.DimsAndBounds(v)
    Debug.Assert dic.Items()(0) = "1 4"
    Debug.Assert dic.Items()(1) = "1 2"

    Dim s(1 To 2, 2 To 3, 3 To 4, 4 To 5, 5 To 6)
    Set dic = o.DimsAndBounds(s)
    Debug.Assert dic.Items()(0) = "1 2"
    Debug.Assert dic.Items()(1) = "2 3"
    Debug.Assert dic.Items()(2) = "3 4"
    Debug.Assert dic.Items()(3) = "4 5"
    Debug.Assert dic.Items()(4) = "5 6"

    Stop
End Sub

注WELL:此答案处理从Range工作表中取出的网格变体。值以及在代码中使用Dim s(1)等创建的数组!其他一些答案不这样做。

Answer 7

我喜欢使用这样一个事实:当出现错误时，新的变量值不会被收取费用。

要获取数组(vArray)的维度(A_Dim)，您可以使用以下代码:

On Error Resume Next
    A_Dim = -1
    Do Until A = "X"
        A_Dim = A_Dim + 1
        A = "X"
        A = UBound(vArray, A_Dim + 1)
    Loop
On Error GoTo 0

Answer 8

Function ArrayDimension(ByRef ArrayX As Variant) As Byte
    Dim i As Integer, a As String, arDim As Byte
    On Error Resume Next
    i = 0
    Do
        a = CStr(ArrayX(0, i))
        If Err.Number > 0 Then
            arDim = i
            On Error GoTo 0
            Exit Do
        Else
             i = i + 1
        End If
    Loop
    If arDim = 0 Then arDim = 1
    ArrayDimension = arDim
End Function

Answer 9

我发现了一种非常简单的检查方法，可能包含一堆编码错误、不正确的术语和不明智的技术，但从来没有减少:

Dim i as Long
Dim VarCount as Long
Dim Var as Variant
'generate your variant here
i = 0
VarCount = 0
recheck1:
  If IsEmpty(Var(i)) = True Then GoTo VarCalc
    i = i + 1
    GoTo recheck1
VarCalc:
  VarCount= i - 1

注意:如果Var(0)不存在，VarCount显然会返回一个负数。VarCount是Var(i)使用的最大参考数，i是您拥有的变体数。

Answer 10

如果只使用ubound(var) + 1呢?这应该会给出大多数变量的最后一个元素(除非它是一个自定义范围，但在这种情况下，您应该已经知道该信息)。常规变量的范围(例如，当使用split函数时)从0开始;Ubound为您提供变量的最后一项。例如，如果你有一个有8个元素的变量，它会从0(上绑定)到7(上绑定)，你可以知道元素的数量，只要加上ubound(var) + 1。例如:

Public Sub PrintQntElements()
    Dim str As String
    Dim var As Variant
    Dim i As Integer
    str = "Element1!Element2!Element3!Element4!Element5!Element6!Element7!Element8"
    var = Split(str, "!")
    i = UBound(var) + 1
    Debug.Print "First element: " & LBound(var)
    Debug.Print "Last element: " & UBound(var)
    Debug.Print "Quantity of elements: " & i
End Sub

它将把以下输出输出到"即时"窗口:
第一个元素:0
最后一个元素:7
元素数量:8

同样，如果您不确定第一个元素(lbound)是否为0，您可以使用:

i = UBound(var) - LBound(var) + 1