你能给我推荐一个很好的替代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支持指针，但仅限于非常有限的程度，并且主要用于需要指针的API函数(通过VarPtr, StrPtr和ObjPtr)。你可以做一点hack来获取数组内存区域的基址。VBA将数组实现为SAFEARRAY结构，因此第一个棘手的部分是获取数据区域的内存地址。我发现这样做的唯一方法是让运行时框在一个变体中数组，然后把它分开:
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
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
这是不是一个好主意或者比你现在做的更好，留给读者作为练习。
你可以这样做:
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。
为了补充这些答案，我发现了一个非常好的(我认为)方法来取消引用指针:
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://learn.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
您可以使用带有引用参数的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
不幸的是，+=在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