1

私の質問は簡単です。C++ で行うように、VBA で配列の 2 つの部分を参照によって取得することは可能ですか? C++ でコーディングしてからしばらく経ったので、今はどのようにコーディングしているかよく思い出せません。覚えていれば、例があるかもしれません。

私がやろうとしているのは、オブジェクトの配列を単一の Double 型プロパティでソートすることです。以前に 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 に答える