All geek questions in one place

Good replacement of references / pointers in VBA?

Can you recommend me a good replacement for reference or pointer types in VBA? I struggled with such expressions for a long time:

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

If I wanted to accumulate values ​​in a multidimensional array, for example. C ++, I could write this:

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

or

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

I am looking for something like this.

I don’t want to repeat the item on the right side of the job, and I don’t want to call the function with ByRef arguments, because it makes code maintenance difficult.

Any ideas?

+4
source share
4 answers

VBA , API, ( VarPtr, StrPtr ObjPtr). , . 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

, , , .

+6

- :

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 .

+3

, += 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

or this 1 size monster (which I probably made a mistake)

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

or possibly gear arrays

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
+1
source

You can use sub with reference parameters:

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

used as follows:

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
0
source

Source: https://habr.com/ru/post/1652453/

More articles:


All Articles