按引用的部分数组 [英] Partial Arrays by reference

问题描述

我的问题很简单:是否可以像我在 C++ 中所做的那样，通过引用在 VBA 中检索数组的两个部分?自从我用 C++ 编码以来已经有一段时间了，所以我不太记得我现在是怎么做的.也许如果我记得，我会举个例子.

My question is simple: Is it possible to, like I would do in C++, to retrieve two parts of an array in VBA by reference? It's been a while since I coded in C++, so I can't quite remember how I do it right now. Maybe if I remember, I'll have an example.

我想要做的是按单个 Double-type 属性对对象数组进行排序.我以前用C++做过，只是没有源码了.

What I am trying to do is sort an array of objects by a single Double-type property. I've done it before in C++, just don't have the source code anymore.

我怀疑是否有用于此的预定义函数，但如果有人知道更好的解决方案，将非常受欢迎.;)

I doubt that there is a predefined function to use for this, but if anybody knows a better solution, it'll be welcomed greatly. ;)

这基本上就是我想要的:

This is basically what I want:

source array(0, 1, 2, 3, 4, 5)

split source array in two
array a(0, 1, 2)
array b(3, 4, 5)

set array a(0) = 4
array a(4, 1, 2)
array b(3, 4, 5)
source array(4, 1, 2, 3, 4, 5)

当然这只是一个抽象的描述.

Of course this is only an abstract description.

如果已经有一个问题与此有关，我很抱歉，那么我还没有找到它.

I apologize if there already is a question dealing with this, I then have not found it.

推荐答案

注意:代码已更新，原始版本可在修订历史a>(不是说找到它有用).更新后的代码不依赖于未公开的 GetMem* 函数，并且与 Office 64 位兼容.

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.

是的，你可以.您必须构建一个 SAFEARRAY 手动使用描述符，以便它指向原始数组数据的子集.

Yes, you can. You will have to construct a SAFEARRAY descriptor manually though, so that it points to a subset of the original array's data.

模块:

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 SafeArrayAllocDescriptor Lib "oleaut32" (ByVal cDims As Long, ByVal ppsaOut As LongPtr) As Long
  Private Declare PtrSafe Function SafeArrayDestroyDescriptor Lib "oleaut32" (ByVal psa As LongPtr) 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 SafeArrayAllocDescriptor Lib "oleaut32" (ByVal cDims As Long, ppsaOut As Any) As Long
  Private Declare Function SafeArrayDestroyDescriptor Lib "oleaut32" (psa As Any) 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 ppArrPtr(ByRef arr As Variant) As LongPtr
#Else
Private Function ppArrPtr(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(ppArrPtr), ByVal VarPtr(arr) + 8, Len(ppArrPtr)  'pArrPtr = arr->pparray;
  Else
    'Non-by-ref variant array. Contains *parray at offset 8
    Err.Raise 5, , "The array must be passed by reference."
  End If
End Function

#If VBA7 Then
Public Function CreateSAFEARRAY(ByRef BlankArray As Variant, ByVal ElemSize As Long, ByVal pData As LongPtr, ParamArray Bounds()) As LongPtr
#Else
Public Function CreateSAFEARRAY(ByRef BlankArray As Variant, ByVal ElemSize As Long, ByVal pData As Long, ParamArray Bounds()) As Long
#End If

 'ParamArray Bounds describes desired array dimensions in VB style
 'bounds(0) - lower bound of first dimension
 'bounds(1) - upper bound of first dimension
 'bounds(2) - lower bound of second dimension
 'bounds(3) - upper bound of second dimension
 'etc

  If (UBound(Bounds) - LBound(Bounds) + 1) Mod 2 Then Err.Raise 5, "SafeArray", "Bounds must contain even number of entries."

#If VBA7 Then
  Dim ppBlankArr As LongPtr
#Else
  Dim ppBlankArr As Long
#End If

  ppBlankArr = ppArrPtr(BlankArray)

  If SafeArrayAllocDescriptor((UBound(Bounds) - LBound(Bounds) + 1) / 2, ByVal ppBlankArr) <> S_OK Then Err.Raise 5

  CopyMemory ByVal VarPtr(CreateSAFEARRAY), ByVal ppBlankArr, Len(CreateSAFEARRAY)  ' CreateSAFEARRAY = *ppBlankArr
  CopyMemory ByVal CreateSAFEARRAY + 4, ByVal VarPtr(ElemSize), Len(ElemSize)       ' CreateSAFEARRAY->cbElements = ElemSize
  CopyMemory ByVal CreateSAFEARRAY + 12, ByVal VarPtr(pData), Len(pData)            ' CreateSAFEARRAY->pvData = pData

  Dim i As Long

  For i = LBound(Bounds) To UBound(Bounds) - 1 Step 2
    If Bounds(i + 1) - Bounds(i) + 1 > 0 Then
      Dim dimensions_data(1 To 2) As Long
      dimensions_data(1) = Bounds(i + 1) - Bounds(i) + 1
      dimensions_data(2) = Bounds(i)

      CopyMemory ByVal CreateSAFEARRAY + 16 + (UBound(Bounds) - i - 1) * 4, ByVal VarPtr(dimensions_data(LBound(dimensions_data))), Len(dimensions_data(LBound(dimensions_data))) * 2 ' CreateSAFEARRAY->rgsabound[i] = number of elements, lower bound
    Else
      SafeArrayDestroyDescriptor ByVal CreateSAFEARRAY
      CreateSAFEARRAY = 0
      CopyMemory ByVal ppBlankArr, ByVal VarPtr(CreateSAFEARRAY), Len(ppBlankArr) ' ppBlankArr = NULL (because CreateSAFEARRAY is now 0)
      Err.Raise 5, , "Each dimension must contain at least 1 element"
    End If
  Next
End Function

Public Sub DestroySAFEARRAY(ByRef ManualArray As Variant)
#If VBA7 Then
  Dim ppManualArr As LongPtr
  Dim pManualArr As LongPtr
#Else
  Dim ppManualArr As Long
  Dim pManualArr As Long
#End If

  ppManualArr = ppArrPtr(ManualArray)
  CopyMemory ByVal VarPtr(pManualArr), ByVal ppManualArr, Len(pManualArr)  ' pManualArr = *ppManualArr

  If SafeArrayDestroyDescriptor(ByVal pManualArr) <> S_OK Then Err.Raise 5

  pManualArr = 0 ' Simply to get a LongPtr-sized zero
  CopyMemory ByVal ppManualArr, ByVal VarPtr(pManualArr), Len(ppManualArr)  'ppManualArr = NULL
End Sub

用法:

Dim source(0 To 5) As Long
source(0) = 0: source(1) = 1: source(2) = 2: source(3) = 3: source(4) = 4: source(5) = 5

Dim a() As Long
Dim b() As Long

CreateSAFEARRAY a, 4, VarPtr(source(0)), 0, 2
CreateSAFEARRAY b, 4, VarPtr(source(3)), 0, 2

MsgBox b(0)

a(0) = 4

DestroySAFEARRAY a
DestroySAFEARRAY b

MsgBox source(0)

确保在原始数组变量被 Erase 或超出范围破坏之前手动销毁子数组.

Be sure to manually destroy the child arrays before the original array variable gets destroyed by either Erase or going out of scope.

但是，通过引用子例程传递整个数组并提供开始处理的索引号可能更简单.

However, it might be simpler to just pass the whole an array by reference to a subroutine and also provide the index number from which to start processing.

这篇关于按引用的部分数组的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！