VBA 中引用/指针的良好替代品？

Posted 2023-02-19

【中文标题】VBA 中引用/指针的良好替代品？

【英文标题】：A good substitute for references/pointers in VBA?

【发布时间】：2017-01-01 19:26:38

【问题描述】：

你能推荐我一个很好的替代 VBA 中引用或指针类型的方法吗？我一直在为这样的表达而苦苦挣扎：

dblMyArray( i * lngDimension0 + j * lngDimension1 + k * lngDimension2, l * lngDimension3 + m * lngDimension4 ) = dblMyArray( i * lngDimension0 + j * lngDimension1 + k * lngDimension2, l * lngDimension3 + m * lngDimension4 ) + 1

如果我想在多维数组中累积值，例如C++，我可以这样写：

double& rElement = dblMyArray[ i * lngDimension0 + j * lngDimension1 + k * lngDimension2 ][ l * lngDimension3 + m * lngDimension4 ];
rElement += 1;

或

double* pElement = &dblMyArray[ i * lngDimension0 + j * lngDimension1 + k * lngDimension2 ][ l * lngDimension3 + m * lngDimension4 ];
*pElement += 1;

我正在寻找这样的东西。

我不想重复赋值右侧的元素，也不想调用带有 ByRef 参数的函数，因为这会使代码的维护变得更加困难。

有什么想法吗？

【问题讨论】：

为什么首先要在 VBA 中使用类似指针的行为？有什么优势吗？

既然VBA直接支持多维数组，为什么要用指针来模拟呢？

那么答案是：不，没有。

VBA 是一种有点冗长的编程语言，它确实缺少指针。如果你经常做这种事情并且它困扰你，你可以将数组迭代抽象为一个子，比如（Increment(A,i) 它将i 添加到数组A 的每个元素）。它需要是一个ByRef 子，但ByRef 是VBA 中的默认。如果Increment 中的数组参数声明为Variant 类型（与VBA 接近指针一样接近），则应该没有太大问题。

如果您将变量包含在一个类中并手动调整该类，您可以拥有一个模仿基本类型行为的类，并且您应该能够Set 对它的引用。

【参考方案1】：

您可以使用带有引用参数的 sub：

Sub Add2Var(ByRef variable As Double, ByVal value As Double)
    variable = variable + value
End Sub

这样使用：

Sub Test()
    Dim da(1 To 2) As Double
    Dim i As Long
    For i = 1 To 2
        da(i) = i * 1.1
    Next i
    Debug.print da(1), da(2)
    Add2Var da(1), 10.1
    Add2Var da(2), 22.1
    Debug.print da(1), da(2)
End Sub

【讨论】：

谢谢，Vincent G，但我希望它没有函数调用。操作并不总是加法，我不喜欢在编辑器或调试器中跳到一行长的函数。

【参考方案2】：

你可以这样做：

Sub ArrayMap(f As String, A As Variant)
    'applies function with name f to
    'every element in the 2-dimensional array A

    Dim i As Long, j As Long
    For i = LBound(A, 1) To UBound(A, 1)
        For j = LBound(A, 2) To UBound(A, 2)
            A(i, j) = Application.Run(f, A(i, j))
        Next j
    Next i
End Sub

例如：

如果你定义：

Function Increment(x As Variant) As Variant
    Increment = x + 1
End Function

Function TimesTwo(x As Variant) As Variant
    TimesTwo = 2 * x
End Function

那么下面的代码将这两个函数应用于两个数组：

Sub test()
    Dim Vals As Variant

    Vals = Range("A1:C3").Value
    ArrayMap "Increment", Vals
    Range("A1:C3").Value = Vals

    Vals = Range("D1:F3").Value
    ArrayMap "TimesTwo", Vals
    Range("D1:F3").Value = Vals

End Sub

编辑时：这是一个更复杂的版本，它允许传递可选参数。我把它拿出来2个可选参数，但它很容易扩展到更多：

Sub ArrayMap(f As String, A As Variant, ParamArray args() As Variant)
    'applies function with name f to
    'every element in the 2-dimensional array A
    'up to two additional arguments to f can be passed

    Dim i As Long, j As Long
    Select Case UBound(args)
        Case -1:
            For i = LBound(A, 1) To UBound(A, 1)
                For j = LBound(A, 2) To UBound(A, 2)
                    A(i, j) = Application.Run(f, A(i, j))
                Next j
            Next i
        Case 0:
            For i = LBound(A, 1) To UBound(A, 1)
                For j = LBound(A, 2) To UBound(A, 2)
                    A(i, j) = Application.Run(f, A(i, j), args(0))
                Next j
            Next i
        Case 1:
            For i = LBound(A, 1) To UBound(A, 1)
                For j = LBound(A, 2) To UBound(A, 2)
                    A(i, j) = Application.Run(f, A(i, j), args(0), args(1))
                Next j
            Next i
     End Select
End Sub

那么如果你定义如下：

Function Add(x As Variant, y As Variant) As Variant
    Add = x + y
End Function

调用ArrayMap "Add", Vals, 2 将为数组中的所有内容添加2。

进一步编辑：主题的变体。应该是不言自明的：

Sub ArrayMap(A As Variant, f As Variant, Optional arg As Variant)
    'applies operation or function with name f to
    'every element in the 2-dimensional array A
    'if f is "+", "-", "*", "/", or "^", arg is the second argument and is required
    'if f is a function, the second argument is passed if present

    Dim i As Long, j As Long
    For i = LBound(A, 1) To UBound(A, 1)
        For j = LBound(A, 2) To UBound(A, 2)
            Select Case f:
            Case "+":
                A(i, j) = A(i, j) + arg
            Case "-":
                A(i, j) = A(i, j) - arg
            Case "*":
                A(i, j) = A(i, j) * arg
            Case "/":
                A(i, j) = A(i, j) / arg
            Case "^":
                A(i, j) = A(i, j) ^ arg
            Case Else:
                If IsMissing(arg) Then
                    A(i, j) = Application.Run(f, A(i, j))
                Else
                    A(i, j) = Application.Run(f, A(i, j), arg)
                End If
            End Select
        Next j
    Next i
End Sub

然后，例如，ArrayMap A, "+", 1 将对数组中的所有内容加 1。

【讨论】：

现在我们正在使用 VBA 类似的函数指针。 +1

【参考方案3】：

VBA 支持指针，但仅限于非常有限的范围，主要用于需要指针的 API 函数（通过 VarPtr、StrPtr 和 ObjPtr）。你可以做一些hackery来获取数组内存区域的基地址。 VBA 将数组实现为SAFEARRAY 结构，因此第一个棘手的部分是获取数据区域的内存地址。我发现这样做的唯一方法是让运行时将数组放入 VARIANT 中，然后将其分开：

Public Declare Sub CopyMemory Lib "kernel32" Alias _
    "RtlMoveMemory" (Destination As Any, Source As Any, _
    ByVal length As Long)

Private Const VT_BY_REF = &H4000&

Public Function GetBaseAddress(vb_array As Variant) As Long
    Dim vtype As Integer
    'First 2 bytes are the VARENUM.
    CopyMemory vtype, vb_array, 2
    Dim lp As Long
    'Get the data pointer.
    CopyMemory lp, ByVal VarPtr(vb_array) + 8, 4
    'Make sure the VARENUM is a pointer.
    If (vtype And VT_BY_REF) <> 0 Then
        'Dereference it for the variant data address.
        CopyMemory lp, ByVal lp, 4
        'Read the SAFEARRAY data pointer.
        Dim address As Long
        CopyMemory address, ByVal lp, 16
        GetBaseAddress = address
    End If
End Function

第二个棘手的部分是 VBA 没有取消引用指针的本机方法，因此您需要另一个辅助函数来做到这一点：

Public Function DerefDouble(pData As Long) As Double
    Dim retVal As Double
    CopyMemory retVal, ByVal pData, LenB(retVal)
    DerefDouble = retVal
End Function

然后你可以像在 C 中一样使用指针：

Private Sub Wheeeeee()
    Dim foo(3) As Double
    foo(0) = 1.1
    foo(1) = 2.2
    foo(2) = 3.3
    foo(3) = 4.4

    Dim pArray As Long
    pArray = GetBaseAddress(foo)
    Debug.Print DerefDouble(pArray) 'Element 0
    Debug.Print DerefDouble(pArray + 16) 'Element 2
End Sub

这是否是一个好主意或是否比您现在所做的更好，留给读者作为练习。

【讨论】：

令人印象深刻的黑客。 +1（尽管——我认为实际使用它并不是一个好主意。）

【参考方案4】：

不幸的是，VBA 不支持+=，但这里有几个替代方案（我将lngDimension 缩短为d）：

x = i * d0 + j * d1 + k * d2
y = l * d3 + m * d4 

dblMyArray(x,y) = dblMyArray(x,y) + 1

或 5 个维度

Dim dblMyArray(d0, d1, d2, d3, d4) As Double

dblMyArray(i,j,k,l,m) = dblMyArray(i,j,k,l,m) + 1

或者这个一维怪物（我可能弄错了）

Dim dblMyArray(d0 * d1 * d2 * d3 * d4) As Double ' only one dimension

For i = 0 to d0 * d1 * d2 * d3 * d4 Step d1 * d2 * d3 * d4
     For j = i to d1 * d2 * d3 * d4 Step d2 * d3 * d4
          For k = j to d2 * d3 * d4 Step d3 * d4
               For l = k to d3 * d4 Step d4
                    For m = l to d4 Step 1
                          dblMyArray(m) = dblMyArray(m) + 1
                    Next m
               Next l
          Next k
     Next j
Next i

或者可能是锯齿状数组

Dim MyArray , subArray ' As Variant 
MyArray = Array( Array( 1, 2, 3 ), Array( 4, 5, 6 ), Array( 7, 8, 9 ) ) 

' access like MyArray(x)(y) instead of MyArray(x, y)

For Each subArray In MyArray
    For Each item In subArray 
         item = item + 1 ' not sure if it works this way instead of subArray(i)
    Next        
Next

【参考方案5】：

为了补充这些答案，我发现了一种非常好的（我认为）取消引用指针的方法：

Option Explicit

Private Enum BOOL
    API_FALSE = 0
    'Use NOT (result = API_FALSE) for API_TRUE, as TRUE is just non-zero
End Enum

Private Enum VirtualProtectFlags 'See Memory Protection constants: https://docs.microsoft.com/en-gb/windows/win32/memory/memory-protection-constants
    PAGE_EXECUTE_READWRITE = &H40
End Enum

#If Win64 Then 'To decide whether to use 8 or 4 bytes per chunk of memory
    Private Declare Function GetMem Lib "msvbvm60" Alias "GetMem8" (ByRef src As Any, ByRef dest As Any) As Long
#Else
    Private Declare Function GetMem Lib "msvbvm60" Alias "GetMem4" (ByRef src As Any, ByRef dest As Any) As Long
#End If

#If VBA7 Then 'for LongPtr
    Private Declare Function VirtualProtect Lib "kernel32" (ByRef location As Any, ByVal numberOfBytes As Long, ByVal newProtectionFlags As VirtualProtectFlags, ByVal lpOldProtectionFlags As LongPtr) As BOOL
#Else
    Private Declare Function VirtualProtect Lib "kernel32" (ByRef location As Any, ByVal numberOfBytes As Long, ByVal newProtectionFlags As VirtualProtectFlags, ByVal lpOldProtectionFlags As LongPtr) As BOOL
#End If

#If VBA7 Then
    Public Property Let DeRef(ByVal address As LongPtr, ByVal value As LongPtr)
        'unprotect memory for writing
        Dim oldProtectVal As VirtualProtectFlags
        If VirtualProtect(ByVal address, LenB(value), PAGE_EXECUTE_READWRITE, VarPtr(oldProtectVal)) = API_FALSE Then
            Err.Raise 5, Description:="That address is protected memory which cannot be accessed"                
        Else
            GetMem value, ByVal address
        End If
    End Property

    Public Property Get DeRef(ByVal address As LongPtr) As LongPtr
        GetMem ByVal address, DeRef
    End Property

#Else
    Public Property Let DeRef(ByVal address As Long, ByVal value As Long)
        'unprotect memory for writing
        Dim oldProtectVal As VirtualProtectFlags
        If VirtualProtect(ByVal address, LenB(value), PAGE_EXECUTE_READWRITE, VarPtr(oldProtectVal)) = API_FALSE Then
            Err.Raise 5, Description:="That address is protected memory which cannot be accessed"
        Else
            GetMem value, ByVal address
        End If
    End Property

    Public Property Get DeRef(ByVal address As Long) As Long
        GetMem ByVal address, DeRef
    End Property

#End If

我发现它们非常好用，并且使使用指针变得更加简单。这是一个简单的例子：

Public Sub test()
    Dim a As Long, b As Long
    a = 5
    b = 6

    Dim a_address As LongPtr
    a_address = VarPtr(a)

    Dim b_address As LongPtr
    b_address = VarPtr(b)

    DeRef(a_address) = DeRef(b_address) 'the value at &a = the value at &b

    Debug.Assert a = b 'succeeds

End Sub