none
New base for arrays? RRS feed

  • Question

  • If I have an array of, let's say, three dimensions:
    Array(35 To 75, 1 To 20, -11 To 22)

    What's the smartest way to change the base of all the dimmensions of the array?

    So, that it becomes:
    Array(0 to 40, 0 To 19, 0 To 33)
    ...while preserving the vaules in the array.

    And, keeping in mind that the dimmensions doesn't have to be three - in could be anything from 1 to 60.
    And, the base could be 1 and not zero.

    Anyone got a code for that?

    Friday, November 11, 2016 9:47 AM

Answers

  • What's the smartest way to change the base of all the dimmensions of the array?

    Code below without any warranty!

    Andreas.

    Option Explicit
    
    'https://msdn.microsoft.com/en-us/library/windows/desktop/ms221482(v=vs.85).aspx
    
    Private Type SafeArray
      cDims As Integer
      fFeatures As Integer
      cbElements As Long
      cLocks As Long
    #If Win64 Then
      pvData As LongPtr
    #Else
      pvData As Long
    #End If
      'rgSABound(0) As SafeArrayBound
    End Type
    
    Private Type SafeArrayBound
      cElements As Long
      lLbound As Long
    End Type
    
    #If Win64 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal nCount As Long)
    #Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal nCount As Long)
    #End If
    
    Private Sub Example_SetLBound()
      Dim Arr
      Dim i As Long, j As Long, k As Long
      'Create an array
      ReDim Arr(1 To 2, 3 To 4, 5 To 8)
      'Fill
      For i = LBound(Arr) To UBound(Arr)
        For j = LBound(Arr, 2) To UBound(Arr, 2)
          For k = LBound(Arr, 3) To UBound(Arr, 3)
            Arr(i, j, k) = i & "-" & j & "-" & k
          Next
        Next
      Next
      'Set lower bound to 0
      SetLBound Arr
      'Show
      Debug.Print
      For i = LBound(Arr) To UBound(Arr)
        For j = LBound(Arr, 2) To UBound(Arr, 2)
          For k = LBound(Arr, 3) To UBound(Arr, 3)
            Debug.Print "Before "; Arr(i, j, k), "After "; i & "-" & j & "-" & k
          Next
        Next
      Next
    End Sub
    
    Sub SetLBound(ByRef vArray As Variant, Optional ByVal NewLBound As Long)
      'Change the lower bound of all dimensions of an array
      Const VT_BYREF = &H4000
    #If Win64 Then
      Dim vPtr As LongPtr
      Dim vPtrFar As LongPtr
    #Else
      Dim vPtr As Long
      Dim vPtrFar As Long
    #End If
      Dim vType As Integer, i As Integer, Ofs As Long
      Dim SA As SafeArray
      Dim SB() As SafeArrayBound
      If Not IsArray(vArray) Then Exit Sub
      If UBound(vArray) < LBound(vArray) Then Exit Sub
      vPtr = VarPtr(vArray)
      CopyMemory vType, ByVal vPtr, 2
      If vType And VT_BYREF Then
        CopyMemory vPtrFar, ByVal vPtr + 8, Len(vPtrFar)
        CopyMemory vPtr, ByVal vPtrFar, Len(vPtr)
      Else
        CopyMemory vPtr, ByVal vPtr + 8, Len(vPtr)
      End If
      CopyMemory SA, ByVal vPtr, Len(SA)
      ReDim SB(1 To SA.cDims)
    #If Win64 Then
      Ofs = 4 '!!AK: Not sure why, but works :-)
    #Else
      Ofs = 0
    #End If
      CopyMemory SB(1), ByVal vPtr + Len(SA) + Ofs, Len(SB(1)) * SA.cDims
      For i = 1 To SA.cDims
        SB(i).lLbound = NewLBound
      Next
      CopyMemory ByVal vPtr + Len(SA) + Ofs, SB(1), Len(SB(1)) * SA.cDims
    End Sub

    • Marked as answer by Dan ElgaardMVP Saturday, November 12, 2016 9:07 PM
    Friday, November 11, 2016 3:20 PM

All replies

  • That would be very complicated. You'll find code for a one-dimensional array at http://www.cpearson.com/excel/vbaarrays.htm

    That code is already long and complex, using many helper functions. To expand it to work with an arbitrary number of dimensions would be a gargantuan task.

    Better avoid the need for changing the bounds of an array!


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Friday, November 11, 2016 12:57 PM
  • What's the smartest way to change the base of all the dimmensions of the array?

    Code below without any warranty!

    Andreas.

    Option Explicit
    
    'https://msdn.microsoft.com/en-us/library/windows/desktop/ms221482(v=vs.85).aspx
    
    Private Type SafeArray
      cDims As Integer
      fFeatures As Integer
      cbElements As Long
      cLocks As Long
    #If Win64 Then
      pvData As LongPtr
    #Else
      pvData As Long
    #End If
      'rgSABound(0) As SafeArrayBound
    End Type
    
    Private Type SafeArrayBound
      cElements As Long
      lLbound As Long
    End Type
    
    #If Win64 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal nCount As Long)
    #Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal nCount As Long)
    #End If
    
    Private Sub Example_SetLBound()
      Dim Arr
      Dim i As Long, j As Long, k As Long
      'Create an array
      ReDim Arr(1 To 2, 3 To 4, 5 To 8)
      'Fill
      For i = LBound(Arr) To UBound(Arr)
        For j = LBound(Arr, 2) To UBound(Arr, 2)
          For k = LBound(Arr, 3) To UBound(Arr, 3)
            Arr(i, j, k) = i & "-" & j & "-" & k
          Next
        Next
      Next
      'Set lower bound to 0
      SetLBound Arr
      'Show
      Debug.Print
      For i = LBound(Arr) To UBound(Arr)
        For j = LBound(Arr, 2) To UBound(Arr, 2)
          For k = LBound(Arr, 3) To UBound(Arr, 3)
            Debug.Print "Before "; Arr(i, j, k), "After "; i & "-" & j & "-" & k
          Next
        Next
      Next
    End Sub
    
    Sub SetLBound(ByRef vArray As Variant, Optional ByVal NewLBound As Long)
      'Change the lower bound of all dimensions of an array
      Const VT_BYREF = &H4000
    #If Win64 Then
      Dim vPtr As LongPtr
      Dim vPtrFar As LongPtr
    #Else
      Dim vPtr As Long
      Dim vPtrFar As Long
    #End If
      Dim vType As Integer, i As Integer, Ofs As Long
      Dim SA As SafeArray
      Dim SB() As SafeArrayBound
      If Not IsArray(vArray) Then Exit Sub
      If UBound(vArray) < LBound(vArray) Then Exit Sub
      vPtr = VarPtr(vArray)
      CopyMemory vType, ByVal vPtr, 2
      If vType And VT_BYREF Then
        CopyMemory vPtrFar, ByVal vPtr + 8, Len(vPtrFar)
        CopyMemory vPtr, ByVal vPtrFar, Len(vPtr)
      Else
        CopyMemory vPtr, ByVal vPtr + 8, Len(vPtr)
      End If
      CopyMemory SA, ByVal vPtr, Len(SA)
      ReDim SB(1 To SA.cDims)
    #If Win64 Then
      Ofs = 4 '!!AK: Not sure why, but works :-)
    #Else
      Ofs = 0
    #End If
      CopyMemory SB(1), ByVal vPtr + Len(SA) + Ofs, Len(SB(1)) * SA.cDims
      For i = 1 To SA.cDims
        SB(i).lLbound = NewLBound
      Next
      CopyMemory ByVal vPtr + Len(SA) + Ofs, SB(1), Len(SB(1)) * SA.cDims
    End Sub

    • Marked as answer by Dan ElgaardMVP Saturday, November 12, 2016 9:07 PM
    Friday, November 11, 2016 3:20 PM
  • Hi Andreas,

    Seems to be working just fine :-)
    At least with the arrays I've tested on, and need for my project...

    Great work, and thank you for your time :-)

    Saturday, November 12, 2016 9:09 PM