VBA 中 references/pointers 的良好替代品？
A good substitute for references/pointers in VBA?
你能给我推荐一个很好的替代 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 参数的函数，因为那样会使代码的维护变得更加困难。
有什么想法吗？
您可以使用带有参考参数的 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
你可以这样做：
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
On Edit: 这是一个更复杂的版本，允许传递可选参数。我把它拿出来了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 支持指针，但仅在非常有限的范围内并且主要用于需要它们的 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
这是好主意还是比你现在做的更好，留给reader.[=14=练习。 ]
不幸的是 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
或者这个 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
为了补充这些答案，我发现了一种非常好的（我认为）取消引用指针的方法：
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
你能给我推荐一个很好的替代 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 参数的函数，因为那样会使代码的维护变得更加困难。
有什么想法吗？
您可以使用带有参考参数的 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
你可以这样做：
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
On Edit: 这是一个更复杂的版本，允许传递可选参数。我把它拿出来了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 支持指针，但仅在非常有限的范围内并且主要用于需要它们的 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
这是好主意还是比你现在做的更好，留给reader.[=14=练习。 ]
不幸的是 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
或者这个 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
为了补充这些答案，我发现了一种非常好的（我认为）取消引用指针的方法：
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