Question

我的问题很简单：像在C ++中一样，是否有可能通过引用在VBA中检索数组的两个部分？我用C ++编写代码已经有一段时间了，所以我不记得我现在是怎么做的。也许如果我记得，我会有一个例子。

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

我怀疑有一个预定义的功能可用于此，但如果有人知道更好的解决方案，它将受到极大的欢迎。 ;）

这基本上就是我想要的：

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)

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

如果已经有一个问题处理这件事我很抱歉，我还没有找到它。

Answer 1

注意：代码已更新，原始版本可在revision history中找到（并非找到它有用）。更新的代码不依赖于未记录的GetMem*函数，并且与Office 64位兼容。

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

模块：

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销毁或超出范围之前手动销毁子数组。

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

部分数组通过引用

1 个答案: