1

我的问题很简单：是否可以像在 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)

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

如果已经存在处理此问题的问题，我深表歉意，那么我还没有找到它。

4

1 回答 1

5

注意：代码已经更新，可以在修订历史中找到原始版本（不是说找到它有用）。更新后的代码不依赖于未记录的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或超出范围破坏之前手动破坏子数组。

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

于 2012-07-29T22:47:06.717 回答