VBA 数组切片(不是 Pythonic 意义上的) [英] VBA array slices (not in the Pythonic sense)
本文介绍了VBA 数组切片(不是 Pythonic 意义上的)的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我该如何实现这个功能?
公共函数ArraySlice(arr As Variant, 维度为Long, index as Long) As Variant'在这里实现结束函数假设我想要一个数组的切片.我在我想要切片的那个维度上指定了一个数组、一个维度和一个索引.
举一个具体的例子，假设我有以下 5x4 二维数组
0 1 2 3 4_____________0|1 1 2 3 11|3 4 2 1 52|4 5 3 2 63|3 5 2 1 3如果水平维度为 1，垂直维度为 2，ArraySlice(array, 1, 3) 的返回值将是一个 1x4 的二维数组.所选维度 2 已展平，唯一剩余的值是最初位于维度 2 上索引 3 的值:
<代码> 0____0|31|12|23|1
您将如何在 VBA 中实现这一点?我能想到的唯一实现将涉及 CopyMemory，除非我限制允许的维数并在每种情况下进行硬编码.
注意:这是我获取数组维度的方法
更新
这里有几个操作示例
对于二维数组
0 1 2 3 4_____________0|1 1 2 3 11|3 4 2 1 52|4 5 3 2 63|3 5 2 1 3ArraySlice(array, 2, 2) 的结果是
0 1 2 3 4_____________0|4 5 3 2 6假设我有一个由以下二维切片组成的 3x3x3 数组此示例已更改以使其更清晰
0 1 2 0 1 2 0 1 20 _________ 1 _________ 2 _________0|1 1 1 0|4 4 4 0|7 7 71|2 2 2 1|5 5 5 1|8 8 82|3 3 3 2|6 6 6 2|9 9 9(这样构造)
Dim arr() As LongReDim arr(2, 2, 2)arr(0, 0, 0) = 1arr(1, 0, 0) = 1arr(2, 0, 0) = 1arr(0, 1, 0) = 2arr(1, 1, 0) = 2arr(2, 1, 0) = 2arr(0, 2, 0) = 3arr(1, 2, 0) = 3arr(2, 2, 0) = 3arr(0, 0, 1) = 4arr(1, 0, 1) = 4arr(2, 0, 1) = 4arr(0, 1, 1) = 5arr(1, 1, 1) = 5arr(2, 1, 1) = 5arr(0, 2, 1) = 6arr(1, 2, 1) = 6arr(2, 2, 1) = 6arr(0, 0, 2) = 7arr(1, 0, 2) = 7arr(2, 0, 2) = 7arr(0, 1, 2) = 8arr(1, 1, 2) = 8arr(2, 1, 2) = 8arr(0, 2, 2) = 9arr(1, 2, 2) = 9arr(2, 2, 2) = 9(维度用于数学 x、y、z 意义，而不是行/列意义)
ArraySlice(array, 3, 1) 的结果将是 3x3x1 数组
<代码> 0 1 20 _________0|4 4 41|5 5 52|6 6 6
ArraySlice(array, 2, 2) 的结果将是 3x1x3 数组
0 1 2 0 1 2 0 1 20 _________ 1 _________ 2 _________0|3 3 3 0|6 6 6 0|9 9 9更新2
对于 DavidZemens，这里有一个示例，可以更轻松地跟踪所涉及的元素:
对于像这样构造的 3x3x3 数组
Dim arr() As LongReDim arr(2, 2, 2)arr(0, 0, 0) = "000"arr(1, 0, 0) = "100"arr(2, 0, 0) = "200"arr(0, 1, 0) = "010"arr(1, 1, 0) = "110"arr(2, 1, 0) = "210"arr(0, 2, 0) = "020"arr(1, 2, 0) = "120"arr(2, 2, 0) = "220"arr(0, 0, 1) = "001"arr(1, 0, 1) = "101"arr(2, 0, 1) = "201"arr(0, 1, 1) = "011"arr(1, 1, 1) = "111"arr(2, 1, 1) = "211"arr(0, 2, 1) = "021"arr(1, 2, 1) = "121"arr(2, 2, 1) = "221"arr(0, 0, 2) = "001"arr(1, 0, 2) = "102"arr(2, 0, 2) = "202"arr(0, 1, 2) = "012"arr(1, 1, 2) = "112"arr(2, 1, 2) = "212"arr(0, 2, 2) = "022"arr(1, 2, 2) = "122"arr(2, 2, 2) = "222"ArraySlice(array, 3, 1) 的结果将是 3x3x1 数组
<代码> 0 1 20 _____0|001" 101" 201"1|"011" "111" "211"2|"021" "121" "221"
最终更新
这是完整的解决方案 - 您可以假设 Array 函数是按照@GSerg 在接受的答案中建议的那样实现的.我认为完全展平切片维度更有意义，因此如果 3x3x3 数组(立方体")的切片是 3x1x3，它会被展平为 3x3.我仍然需要解决通过这种方法展平一维数组会产生 0 维数组的情况.
公共函数ArraySlice(arr As Variant,维度As Long, index As Long) As Variant'TODO: 断言 arr 是一个数组'TODO: 断言维度有效'TODO: 断言索引有效将 arrDims 调暗为整数arrDims = GetArrayDim(arr) 'N 维将 arrType 调暗为整数arrType = GetArrayType(arr)Dim zeroIndexedDimension 作为整数zeroIndexedDimension =维度 - 1 '通过减一使维度零索引，以便于数学将 newArrDims 调暗为整数newArrDims = arrDims - 1 'N-1 个维度，因为我们在索引"上展平了维度"Dim arrDimSizes() 作为变体Dim newArrDimSizes() 作为变体ReDim arrDimSizes(0 到 arrDims - 1)ReDim newArrDimSizes(0 到 newArrDims - 1)昏暗的我对于 i = 0 到 arrDims - 1arrDimSizes(i) = UBound(arr, i + 1) - LBound(arr, i + 1) + 1下一个'获取原始每个对应维度的大小对于 i = 0 到 zeroIndexedDimension - 1newArrDimSizes(i) = arrDimSizes(i)下一个'跳过维度"，因为我们正在将其展平'得到剩余的维度，减一对于 i = zeroIndexedDimension To arrDims - 2newArrDimSizes(i) = arrDimSizes(i + 1)下一个Dim newArray 作为变体newArray = CreateArray(arrType, newArrDims, newArrDimSizes)'遍历维度，复制Dim arrCurIndices() 作为变体Dim newArrCurIndices() 作为变体ReDim arrCurIndices(0 到 arrDims - 1)ReDim newArrCurIndices(0 到 newArrDims - 1)arrCurIndices(zeroIndexedDimension) = index '这是切片做同时 1'复制元素PutArrayElement newArray, GetArrayElement(arr, arrCurIndices), newArrCurIndices'将两个数组迭代到下一个位置如果不是 IncrementIndices(arrCurIndices, arrDimSizes, zeroIndexedDimension) 然后'如果我们复制了所有元素退出做万一IncrementIndices newArrCurIndices, newArrDimSizes环形ArraySlice = newArray结束函数私有函数 IncrementIndices(arrIndices As Variant, arrDimensionSizes As Variant, Optional zeroIndexedDimension As Integer = -2) As Boolean'IncrementArray 顺序迭代所有有效索引，给定 arrDimensionSizes 中的大小'例如，假设以 [0, 0, 0] 的起始 arrIndices 和 [3, 1, 3] 的 arrDimensionSizes 重复调用该函数.'结果将是 arrIndices 更改如下:'[0, 0, 0] 第一次调用'[0, 0, 1]'[0, 0, 2]'[1, 0, 0]'[1, 0, 1]'[1, 0, 2]'[2, 0, 0]'[2, 0, 1]'[2, 0, 2]'可选的维度"参数允许维度被冻结并且不包括在迭代中.'例如，假设以 [0, 1, 0] 的起始 arrIndices 和 [3, 3, 3] 的 arrDimensionSizes 和维度 = 2 重复调用该函数'[0, 1, 0] 第一次调用'[0, 1, 1]'[0, 1, 2]'[1, 1, 0]'[1, 1, 1]'[1, 1, 2]'[2, 1, 0]'[2, 1, 1]'[2, 1, 2]Dim arrCurDimension 作为整数arrCurDimension = UBound(arrIndices)'如果这个维度是满的"或者如果它是冻结维度，跳过它寻找进位而 arrIndices(arrCurDimension) = arrDimensionSizes(arrCurDimension) - 1 或 arrCurDimension = zeroIndexedDimension'携带arrCurDimension = arrCurDimension - 1如果 arrCurDimension = -1 那么IncrementIndices = False退出函数万一温德arrIndices(arrCurDimension) = arrIndices(arrCurDimension) + 1当 arrCurDimension zeroIndexedDimension 然后arrIndices(arrCurDimension) = 0万一温德IncrementIndices = 真结束函数 解决方案
注意:代码已更新，原始版本可在修订历史记录(不是说找到它有用).更新后的代码不依赖于未公开的
GetMem*函数，并且与 Office 64 位兼容.
我不确定我是否完全理解函数参数和结果之间的逻辑和联系，但是已经有一个通用的元素访问器函数，SafeArrayGetElement.它允许您在编译时访问维度未知的数组元素，您只需要数组指针.>
在单独的模块中:
选项显式#如果 VBA7 那么Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As LongPtr)Private Declare PtrSafe Function SafeArrayGetElement Lib "oleaut32.dll" (ByVal psa As LongPtr, ByRef rgIndices As Long, ByRef pv As Any) As LongPrivate Declare PtrSafe Function SafeArrayGetVartype Lib "oleaut32.dll" (ByVal psa As LongPtr, ByRef pvt As Integer) As Long#别的Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)私有声明函数 SafeArrayGetElement Lib "oleaut32.dll" (ByVal psa As Long, ByRef rgIndices As Long, ByRef pv As Any) As Long私有声明函数 SafeArrayGetVartype Lib "oleaut32.dll" (ByVal psa As Long, ByRef pvt As Integer) As Long#万一Private Const VT_BYREF As Long = &H4000&Private Const S_OK As Long = &H0&' 以这种方式声明时，传递的数组将包装在 Variant/ByRef 中.它不是复制的.' 返回 *SAFEARRAY，而不是 **SAFEARRAY#如果 VBA7 那么私有函数 pArrPtr(ByRef arr As Variant) As LongPtr#别的私有函数 pArrPtr(ByRef arr As Variant) As Long#万一'VarType 对你说谎，隐藏了重要的差异.手动 VarType 在这里.将 vt 变暗为整数CopyMemory ByVal VarPtr(vt), ByVal VarPtr(arr), Len(vt)如果 (vt 和 vbArray) <>vbArray 然后Err.Raise 5, , "Variant 必须包含一个数组"万一'见 https://msdn.microsoft.com/en-us/library/windows/desktop/ms221627%28v=vs.85%29.aspx如果 (vt And VT_BYREF) = VT_BYREF 那么'By-ref 变体数组.包含偏移量 8 处的 **pparrayCopyMemory ByVal VarPtr(pArrPtr), ByVal VarPtr(arr) + 8, Len(pArrPtr) 'pArrPtr = arr->pparray;CopyMemory ByVal VarPtr(pArrPtr), ByVal pArrPtr, Len(pArrPtr) 'pArrPtr = *pArrPtr;别的'非引用变量数组.包含偏移量 8 处的 *parrayCopyMemory ByVal VarPtr(pArrPtr), ByVal VarPtr(arr) + 8, Len(pArrPtr) 'pArrPtr = arr->parray;万一结束函数Public Function GetArrayElement(ByRef arr As Variant, ParamArray Indices() As Variant) As Variant#如果 VBA7 那么将 pSafeArray 调暗为 LongPtr#别的将 pSafeArray 调暗至长#万一pSafeArray = pArrPtr(arr)Dim long_indices() 长ReDim long_indices(0 to UBound(indices) - LBound(indices))昏暗的我对于 i = LBound(long_indices) 到 UBound(long_indices)long_indices(i) = 指数(LBound(indices) + i)下一个'类型安全检查 - 如果您知道自己在做什么，则删除/缓存.昏暗的结果将 vt 变暗为整数hresult = SafeArrayGetVartype(pSafeArray, vt)如果 hresult <>S_OK 然后 Err.Raise hresult, , "无法获取数组 var 类型."选择案例 vt案例 vbVarianthresult = SafeArrayGetElement(ByVal pSafeArray, long_indices(LBound(long_indices)), GetArrayElement)案例 vbBoolean, vbCurrency, vbDate, vbDecimal, vbByte, vbInteger, vbLong, vbNull, vbEmpty, vbSingle, vbDouble, vbString, vbObjecthresult = SafeArrayGetElement(ByVal pSafeArray, long_indices(LBound(long_indices)), ByVal VarPtr(GetArrayElement) + 8)如果 hresult = S_OK 然后 CopyMemory ByVal VarPtr(GetArrayElement), ByVal VarPtr(vt), Len(vt)其他情况Err.Raise 5, , "不支持的数组元素类型"结束选择如果 hresult <>S_OK 然后 Err.Raise hresult, , "无法获取数组元素."结束函数用法:
私有子命令1_Click()Dim arrVariantByRef() 作为变体ReDim arrVariantByRef(1 到 2, 1 到 3)Dim arrVariantNonByRef 作为变体ReDim arrVariantNonByRef(1 到 2, 1 到 3)Dim arrOfLongs() 一样长ReDim arrOfLongs(1 到 2, 1 到 3)Dim arrOfStrings() 作为字符串ReDim arrOfStrings(1 到 2, 1 到 3)Dim arrOfObjects() 作为对象ReDim arrOfObjects(1 到 2, 1 到 3)Dim arrOfDates() 作为日期ReDim arrOfDates(1 到 2, 1 到 3)arrVariantByRef(2, 3) = 42arrVariantNonByRef(2, 3) = 42arrOfLongs(2, 3) = 42arrOfStrings(2, 3) = "42!"设置 arrOfObjects(2, 3) = 我arrOfDates(2, 3) = 现在MsgBox GetArrayElement(arrVariantByRef, 2, 3)MsgBox GetArrayElement(arrVariantNonByRef, 2, 3)MsgBox GetArrayElement(arrOfLongs, 2, 3)MsgBox GetArrayElement(arrOfStrings, 2, 3)MsgBox GetArrayElement(arrOfObjects, 2, 3).CaptionMsgBox GetArrayElement(arrOfDates, 2, 3)结束子我相信您可以使用这个基本块轻松构建逻辑，尽管它可能比您想要的慢.
您可以删除代码中的一些类型检查 - 这样会更快，但您必须确保只传递正确的基础类型的数组.您还可以缓存 pArray 并使 GetArrayElement 接受它而不是原始数组.
How should I implement this function?
Public Function ArraySlice(arr As Variant, dimension as Long, index as Long) As Variant
'Implementation here
End Function
Suppose I wanted a slice of an array. I specify an array, a dimension and an index on that dimension for which I want the slice.
As a concrete example, suppose I have the following 5x4 2D array
0 1 2 3 4
______________
0| 1 1 2 3 1
1| 3 4 2 1 5
2| 4 5 3 2 6
3| 3 5 2 1 3
If the horizontal dimension is 1 and the vertical is 2, the return value of ArraySlice(array, 1, 3) would be a 1x4 2D array. The chosen dimension 2 was flattened and the only remaining values are the ones that were originally at index 3 on dimension 2:
0
____
0| 3
1| 1
2| 2
3| 1
How would you implement this in VBA? The only implementations I can think of would involve CopyMemory unless I limited the number of dimensions allowable and hard coded every case.
NOTE: Here is how I would get the dimensions of the array
UPDATE
Here are a couple more examples of the operation
For the 2D array
0 1 2 3 4
______________
0| 1 1 2 3 1
1| 3 4 2 1 5
2| 4 5 3 2 6
3| 3 5 2 1 3
The result of ArraySlice(array, 2, 2) would be
0 1 2 3 4
______________
0| 4 5 3 2 6
Suppose I had a 3x3x3 array comprised of the following 2 dimensional slices this example has been changed to make it clearer
0 1 2 0 1 2 0 1 2
0 _________ 1 _________ 2 _________
0| 1 1 1 0| 4 4 4 0| 7 7 7
1| 2 2 2 1| 5 5 5 1| 8 8 8
2| 3 3 3 2| 6 6 6 2| 9 9 9
(constructed like so)
Dim arr() As Long
ReDim arr(2, 2, 2)
arr(0, 0, 0) = 1
arr(1, 0, 0) = 1
arr(2, 0, 0) = 1
arr(0, 1, 0) = 2
arr(1, 1, 0) = 2
arr(2, 1, 0) = 2
arr(0, 2, 0) = 3
arr(1, 2, 0) = 3
arr(2, 2, 0) = 3
arr(0, 0, 1) = 4
arr(1, 0, 1) = 4
arr(2, 0, 1) = 4
arr(0, 1, 1) = 5
arr(1, 1, 1) = 5
arr(2, 1, 1) = 5
arr(0, 2, 1) = 6
arr(1, 2, 1) = 6
arr(2, 2, 1) = 6
arr(0, 0, 2) = 7
arr(1, 0, 2) = 7
arr(2, 0, 2) = 7
arr(0, 1, 2) = 8
arr(1, 1, 2) = 8
arr(2, 1, 2) = 8
arr(0, 2, 2) = 9
arr(1, 2, 2) = 9
arr(2, 2, 2) = 9
(the dimensions are used in the mathematical x, y, z sense as opposed to the rows/cols sense)
The result of ArraySlice(array, 3, 1) would be the 3x3x1 array
0 1 2
0 _________
0| 4 4 4
1| 5 5 5
2| 6 6 6
The result of ArraySlice(array, 2, 2) would be the 3x1x3 array
0 1 2 0 1 2 0 1 2
0 _________ 1 _________ 2 _________
0| 3 3 3 0| 6 6 6 0| 9 9 9
UPDATE2
For DavidZemens, here is an example that would allow easier tracking of the elements involved:
For a 3x3x3 array constructed like so
Dim arr() As Long
ReDim arr(2, 2, 2)
arr(0, 0, 0) = "000"
arr(1, 0, 0) = "100"
arr(2, 0, 0) = "200"
arr(0, 1, 0) = "010"
arr(1, 1, 0) = "110"
arr(2, 1, 0) = "210"
arr(0, 2, 0) = "020"
arr(1, 2, 0) = "120"
arr(2, 2, 0) = "220"
arr(0, 0, 1) = "001"
arr(1, 0, 1) = "101"
arr(2, 0, 1) = "201"
arr(0, 1, 1) = "011"
arr(1, 1, 1) = "111"
arr(2, 1, 1) = "211"
arr(0, 2, 1) = "021"
arr(1, 2, 1) = "121"
arr(2, 2, 1) = "221"
arr(0, 0, 2) = "001"
arr(1, 0, 2) = "102"
arr(2, 0, 2) = "202"
arr(0, 1, 2) = "012"
arr(1, 1, 2) = "112"
arr(2, 1, 2) = "212"
arr(0, 2, 2) = "022"
arr(1, 2, 2) = "122"
arr(2, 2, 2) = "222"
The result of ArraySlice(array, 3, 1) would be the 3x3x1 array
0 1 2
0 ___________________
0| "001" "101" "201"
1| "011" "111" "211"
2| "021" "121" "221"
FINAL UPDATE
Here is the complete solution - you can assume that the Array functions are implemented as @GSerg suggests in the accepted answer. I decided that it makes more sense to completely flatten the sliced dimension, so if a slice of a 3x3x3 array ("cube") is 3x1x3, it gets flattened to 3x3. I still have to resolve the case where flattening a 1 dimensional array would yield a 0 dimensional array by this method.
Public Function ArraySlice(arr As Variant, dimension As Long, index As Long) As Variant
'TODO: Assert that arr is an Array
'TODO: Assert dimension is valid
'TODO: Assert index is valid
Dim arrDims As Integer
arrDims = GetArrayDim(arr) 'N dimensions
Dim arrType As Integer
arrType = GetArrayType(arr)
Dim zeroIndexedDimension As Integer
zeroIndexedDimension = dimension - 1 'Make the dimension zero indexed by subtracting one, for easier math
Dim newArrDims As Integer
newArrDims = arrDims - 1 'N-1 dimensions since we're flattening "dimension" on "index"
Dim arrDimSizes() As Variant
Dim newArrDimSizes() As Variant
ReDim arrDimSizes(0 To arrDims - 1)
ReDim newArrDimSizes(0 To newArrDims - 1)
Dim i As Long
For i = 0 To arrDims - 1
arrDimSizes(i) = UBound(arr, i + 1) - LBound(arr, i + 1) + 1
Next
'Get the size of each corresponding dimension of the original
For i = 0 To zeroIndexedDimension - 1
newArrDimSizes(i) = arrDimSizes(i)
Next
'Skip over "dimension" since we're flattening it
'Get the remaining dimensions, off by one
For i = zeroIndexedDimension To arrDims - 2
newArrDimSizes(i) = arrDimSizes(i + 1)
Next
Dim newArray As Variant
newArray = CreateArray(arrType, newArrDims, newArrDimSizes)
'Iterate through dimensions, copying
Dim arrCurIndices() As Variant
Dim newArrCurIndices() As Variant
ReDim arrCurIndices(0 To arrDims - 1)
ReDim newArrCurIndices(0 To newArrDims - 1)
arrCurIndices(zeroIndexedDimension) = index 'This is the slice
Do While 1
'Copy the element
PutArrayElement newArray, GetArrayElement(arr, arrCurIndices), newArrCurIndices
'Iterate both arrays to the next position
If Not IncrementIndices(arrCurIndices, arrDimSizes, zeroIndexedDimension) Then
'If we've copied all the elements
Exit Do
End If
IncrementIndices newArrCurIndices, newArrDimSizes
Loop
ArraySlice = newArray
End Function
Private Function IncrementIndices(arrIndices As Variant, arrDimensionSizes As Variant, Optional zeroIndexedDimension As Integer = -2) As Boolean
'IncrementArray iterates sequentially through all valid indices, given the sizes in arrDimensionSizes
'For example, suppose the function is called repeatedly with starting arrIndices of [0, 0, 0] and arrDimensionSizes of [3, 1, 3].
'The result would be arrIndices changing as follows:
'[0, 0, 0] first call
'[0, 0, 1]
'[0, 0, 2]
'[1, 0, 0]
'[1, 0, 1]
'[1, 0, 2]
'[2, 0, 0]
'[2, 0, 1]
'[2, 0, 2]
'The optional "dimension" parameter allows a dimension to be frozen and not included in the iteration.
'For example, suppose the function is called repeatedly with starting arrIndices of [0, 1, 0] and arrDimensionSizes of [3, 3, 3] and dimension = 2
'[0, 1, 0] first call
'[0, 1, 1]
'[0, 1, 2]
'[1, 1, 0]
'[1, 1, 1]
'[1, 1, 2]
'[2, 1, 0]
'[2, 1, 1]
'[2, 1, 2]
Dim arrCurDimension As Integer
arrCurDimension = UBound(arrIndices)
'If this dimension is "full" or if it is the frozen dimension, skip over it looking for a carry
While arrIndices(arrCurDimension) = arrDimensionSizes(arrCurDimension) - 1 Or arrCurDimension = zeroIndexedDimension
'Carry
arrCurDimension = arrCurDimension - 1
If arrCurDimension = -1 Then
IncrementIndices = False
Exit Function
End If
Wend
arrIndices(arrCurDimension) = arrIndices(arrCurDimension) + 1
While arrCurDimension < UBound(arrDimensionSizes)
arrCurDimension = arrCurDimension + 1
If arrCurDimension <> zeroIndexedDimension Then
arrIndices(arrCurDimension) = 0
End If
Wend
IncrementIndices = True
End Function
解决方案
Note: the code has been updated, the original version can be found in the revision history (not that it is useful to find it). The updated code does not depend on the undocumented
GetMem*functions and is compatible with Office 64-bit.
I'm not sure I fully understand the logic and the connection between the function arguments and the result, but there already is a generic element accessor function, SafeArrayGetElement. It lets you access an element of an array with dimensions unknown at compile time, all you need is the array pointer.
In a separate module:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As LongPtr)
Private Declare PtrSafe Function SafeArrayGetElement Lib "oleaut32.dll" (ByVal psa As LongPtr, ByRef rgIndices As Long, ByRef pv As Any) As Long
Private Declare PtrSafe Function SafeArrayGetVartype Lib "oleaut32.dll" (ByVal psa As LongPtr, ByRef pvt As Integer) As Long
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
Private Declare Function SafeArrayGetElement Lib "oleaut32.dll" (ByVal psa As Long, ByRef rgIndices As Long, ByRef pv As Any) As Long
Private Declare Function SafeArrayGetVartype Lib "oleaut32.dll" (ByVal psa As Long, ByRef pvt As Integer) As Long
#End If
Private Const VT_BYREF As Long = &H4000&
Private Const S_OK As Long = &H0&
' When declared in this way, the passed array is wrapped in a Variant/ByRef. It is not copied.
' Returns *SAFEARRAY, not **SAFEARRAY
#If VBA7 Then
Private Function pArrPtr(ByRef arr As Variant) As LongPtr
#Else
Private Function pArrPtr(ByRef arr As Variant) As Long
#End If
'VarType lies to you, hiding important differences. Manual VarType here.
Dim vt As Integer
CopyMemory ByVal VarPtr(vt), ByVal VarPtr(arr), Len(vt)
If (vt And vbArray) <> vbArray Then
Err.Raise 5, , "Variant must contain an array"
End If
'see https://msdn.microsoft.com/en-us/library/windows/desktop/ms221627%28v=vs.85%29.aspx
If (vt And VT_BYREF) = VT_BYREF Then
'By-ref variant array. Contains **pparray at offset 8
CopyMemory ByVal VarPtr(pArrPtr), ByVal VarPtr(arr) + 8, Len(pArrPtr) 'pArrPtr = arr->pparray;
CopyMemory ByVal VarPtr(pArrPtr), ByVal pArrPtr, Len(pArrPtr) 'pArrPtr = *pArrPtr;
Else
'Non-by-ref variant array. Contains *parray at offset 8
CopyMemory ByVal VarPtr(pArrPtr), ByVal VarPtr(arr) + 8, Len(pArrPtr) 'pArrPtr = arr->parray;
End If
End Function
Public Function GetArrayElement(ByRef arr As Variant, ParamArray indices() As Variant) As Variant
#If VBA7 Then
Dim pSafeArray As LongPtr
#Else
Dim pSafeArray As Long
#End If
pSafeArray = pArrPtr(arr)
Dim long_indices() As Long
ReDim long_indices(0 To UBound(indices) - LBound(indices))
Dim i As Long
For i = LBound(long_indices) To UBound(long_indices)
long_indices(i) = indices(LBound(indices) + i)
Next
'Type safety checks - remove/cache if you know what you're doing.
Dim hresult As Long
Dim vt As Integer
hresult = SafeArrayGetVartype(pSafeArray, vt)
If hresult <> S_OK Then Err.Raise hresult, , "Cannot get array var type."
Select Case vt
Case vbVariant
hresult = SafeArrayGetElement(ByVal pSafeArray, long_indices(LBound(long_indices)), GetArrayElement)
Case vbBoolean, vbCurrency, vbDate, vbDecimal, vbByte, vbInteger, vbLong, vbNull, vbEmpty, vbSingle, vbDouble, vbString, vbObject
hresult = SafeArrayGetElement(ByVal pSafeArray, long_indices(LBound(long_indices)), ByVal VarPtr(GetArrayElement) + 8)
If hresult = S_OK Then CopyMemory ByVal VarPtr(GetArrayElement), ByVal VarPtr(vt), Len(vt)
Case Else
Err.Raise 5, , "Unsupported array element type"
End Select
If hresult <> S_OK Then Err.Raise hresult, , "Cannot get array element."
End Function
Usage:
Private Sub Command1_Click()
Dim arrVariantByRef() As Variant
ReDim arrVariantByRef(1 To 2, 1 To 3)
Dim arrVariantNonByRef As Variant
ReDim arrVariantNonByRef(1 To 2, 1 To 3)
Dim arrOfLongs() As Long
ReDim arrOfLongs(1 To 2, 1 To 3)
Dim arrOfStrings() As String
ReDim arrOfStrings(1 To 2, 1 To 3)
Dim arrOfObjects() As Object
ReDim arrOfObjects(1 To 2, 1 To 3)
Dim arrOfDates() As Date
ReDim arrOfDates(1 To 2, 1 To 3)
arrVariantByRef(2, 3) = 42
arrVariantNonByRef(2, 3) = 42
arrOfLongs(2, 3) = 42
arrOfStrings(2, 3) = "42!"
Set arrOfObjects(2, 3) = Me
arrOfDates(2, 3) = Now
MsgBox GetArrayElement(arrVariantByRef, 2, 3)
MsgBox GetArrayElement(arrVariantNonByRef, 2, 3)
MsgBox GetArrayElement(arrOfLongs, 2, 3)
MsgBox GetArrayElement(arrOfStrings, 2, 3)
MsgBox GetArrayElement(arrOfObjects, 2, 3).Caption
MsgBox GetArrayElement(arrOfDates, 2, 3)
End Sub
I believe you can easily build your logic using this base block, although it might be slower than you want.
There are some type checks in the code which you can remove - then it will be faster, but you will have to make sure you only pass arrays of correct underlying type. You can also cache the pArray and make GetArrayElement accept that instead of a raw array.
这篇关于VBA 数组切片(不是 Pythonic 意义上的)的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
