我该如何实现这个功能？
Public Function ArraySlice(arr As Variant, dimension as Long, index as Long) As Variant
'Implementation here
End Function
假设我想要一个数组切片.我在该维度上指定了一个数组,一个维度和一个索引,我想要切片.
举一个具体的例子,假设我有以下5x4 2D数组
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
如果水平尺寸为1且垂直尺寸为2,则返回值ArraySlice(array, 1, 3)将为1x4 2D阵列.选定的维度2被展平,唯一剩下的值是最初在维度2的索引3处的值:
0
____
0| 3
1| 1
2| 2
3| 1
你会如何在VBA中实现这一点？我能想到的唯一实现将涉及CopyMemory,除非我限制了允许的维度数量并对每种情况进行硬编码.
注意:这是我如何获得数组的尺寸
UPDATE
以下是一些操作示例
对于2D阵列
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
结果ArraySlice(array, 2, 2)将是
0 1 2 3 4
______________
0| 4 5 3 2 6
假设我有一个由以下2维切片组成的3x3x3阵列, 这个例子已被更改为更清晰
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
(如此构造)
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
(尺寸用于数学x,y,z意义而不是行/列感)
结果ArraySlice(array, 3, 1)将是3x3x1阵列
0 1 2
0 _________
0| 4 4 4
1| 5 5 5
2| 6 6 6
结果ArraySlice(array, 2, 2)将是3x1x3阵列
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
对于DavidZemens,这里有一个例子,可以更容易地跟踪所涉及的元素:
对于像这样构造的3x3x3阵列
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"
结果ArraySlice(array, 3, 1)将是3x3x1阵列
0 1 2
0 ___________________
0| "001" "101" "201"
1| "011" "111" "211"
2| "021" "121" "221"
最终更新
这是完整的解决方案 - 您可以假设Array函数是在接受的答案中以@GSerg建议的方式实现的.我认为完全展平切片尺寸更有意义,因此如果3x3x3阵列("立方体")的切片为3x1x3,则会变平至3x3.我仍然必须解决通过这种方法展平1维数组将产生0维数组的情况.
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
我不确定我是否完全理解函数参数和结果之间的逻辑和连接,但是已经存在一个通用元素访问器函数,GetMem*.它允许您在编译时访问维度未知的数组元素,您只需要数组指针 (仅供参考;此答案中的代码已得到改进).
在一个单独的模块中:
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
用法:
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
我相信你可以使用这个基本块轻松构建你的逻辑,虽然它可能比你想要的慢.
您可以删除代码中的某些类型检查 - 然后它会更快,但您必须确保只传递正确的基础类型的数组.您也可以缓存SafeArrayGetElement并pArray接受而不是原始数组.