use*_*978 28 excel vba variant dimensions
有谁知道如何返回在VBA中传递给它的(Variant)变量的维数？
Jac*_*cob 29
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
这是我能想到的唯一方法.不漂亮….
看看MSDN,他们基本上做了同样的事情.
Flo*_* B. 11
要在不吞咽错误的情况下返回尺寸数量:
#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
对于数组,MS有一个很好的方法,包括循环直到发生错误.
"这个例程通过测试每个维度的LBound来测试名为Xarray的数组.使用For ... Next循环,例程循环遍历可能的数组维度的数量,最多60000,直到生成错误.然后错误处理程序采取循环失败的计数器步骤,减去一个(因为前一个是没有错误的最后一个),并在消息框中显示结果...."
http://support.microsoft.com/kb/152288
清理版本的代码(决定写为函数,而不是sub):
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
@cularis和@Issun对于提出的确切问题有完全足够的答案.不过,我会质问你的问题.你真的有一堆未知维数的数组浮动吗？如果你在Excel中工作,在这种情况发生的唯一情况是UDF,你可能会获得通过或者是1-d阵列或2-d阵列(或非阵列),但没有别的.
你应该几乎从来没有一个期望任意的东西.因此,您可能不应该有一般的"查找数组维度"例程.
所以,考虑到这一点,这是我使用的例程:
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代码中的性能很少如此重要,但它仍然很有趣.
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