Re: redim preserve multidimen array

Tech-Archive recommends: Repair Windows Errors & Optimize Windows Performance


"Russ Holsclaw" <russ@xxxxxxxxxxxxx> wrote
>
> Some years back, I was faced with the task of implementing a matrix ... a
> two-dimension array ... in which *both* dimensions had to be expandable.
> This had to be retrofitted into code that was originally designed to work
> with a matrix whose size was determined at initialization time.
<...>
> My solution was to constuct an "object" that represented the array,
> encapsulating a structure that was, in fact, an array of arrays. One
> advantage of this was that I could write the object so that the matrix
> would automatically "stretch" itself to accomodate whatever data was
> assigned to it.
<...>
> Because the Value property had a syntax identical to that of code that's
> addressing a two-dimensional array, the code that referenced it was very
> little changed, except for the addition of ".Value" between the array name
> and the "subscripts". This could be accomplished with a simple
> Search-and-replace.

You could have avoided the search and replace by assigning the Value
property as the default property of the class (Tools > Procedure Attributes > Advanced)

I tried your code but it would not work as written, here is a class for
copy and paste code into a new class module....

(Remember to set the default property to Matrix to allow for
clsArray(X, Y) = Number type of access!)

LFS

Option Explicit

Private Data() As Variant
Private SizeX As Long, SizeY As Long
Const DEFAULT_VALUE = -2
Const INCREMENT_AMOUNT = 2

Public Property Get Matrix(ByVal x As Long, ByVal y As Long) As Integer
' Set Matrix as default property
Matrix = DEFAULT_VALUE
If (x <= SizeX) And (y <= SizeY) Then
Matrix = Data(x)(y)
End If
End Property

Public Property Let Matrix(ByVal X As Long, ByVal Y As Long, ByVal Value As Integer)
' Increase size as needed
If x > SizeX Then NewSizeX x
If y > SizeY Then NewSizeY y
Data(x)(y) = Value
End Property

Public Sub ReDimension(ByVal SizeX As Long, ByVal SizeY As Long)
If (SizeX > 0) And (SizeY > 0) Then
NewSizeY SizeY
NewSizeX SizeX
End If
End Sub

Private Sub NewSizeX(ByVal Size As Long)
' Increase columns
Dim idx As Long, init As Long
Dim tmp As Variant

If Size > SizeX Then
' Up-size all items in the array
For idx = LBound(Data) To UBound(Data)
tmp = Data(idx)
ReDim Preserve tmp(Size + INCREMENT_AMOUNT)
For init = SizeX + 1 To UBound(tmp)
tmp(init) = DEFAULT_VALUE
Next
Data(idx) = tmp
Next
SizeX = UBound(tmp)
ElseIf Size < SizeX Then
' Down-size all items in the array
For idx = LBound(Data) To UBound(Data)
tmp = Data(idx)
ReDim Preserve tmp(Size)
Data(idx) = tmp
Next
SizeX = UBound(tmp)
End If

End Sub

Private Sub NewSizeY(ByVal Size As Long)
' Increase rows
Dim idx As Long, init As Long
Dim tmp As Variant

If Size > SizeY Then
' Up-size array
ReDim Preserve Data(LBound(Data) To Size + INCREMENT_AMOUNT)
' init new items
For idx = SizeY + 1 To UBound(Data)
ReDim tmp(SizeX)
For init = LBound(tmp) To UBound(tmp)
tmp(init) = DEFAULT_VALUE
Next
Data(idx) = tmp
Next
SizeY = UBound(Data)
ElseIf Size < SizeY Then
' Down-size array
If Size >= LBound(Data) Then
ReDim Preserve Data(LBound(Data) To Size)
End If
End If
End Sub

Friend Sub DeBug_Sizes()
Dim y
For y = LBound(Data) To UBound(Data)
Debug.Print "Row "; y, LBound(Data(y)); " to "; UBound(Data(y))
Next
End Sub

Friend Sub DeBug_Values()
Dim X, Y, Z
For y = LBound(Data) To UBound(Data)
z = Data(y)
For x = LBound(z) To UBound(z)
Debug.Print z(x); ", ";
Next
Debug.Print
Next
End Sub

Private Sub Class_Initialize()
' Init data so LBound/UBound will not error on first use
Dim tmp As Variant
ReDim tmp(0)
tmp(0) = DEFAULT_VALUE
ReDim Data(0)
Data(0) = tmp
End Sub

Private Sub Class_Terminate()
Erase Data
End Sub



.

Relevant Pages

  • Re: Updated datestamp doesnt work
    ... Public Sub StoreMyOldVals ... ' store values of current row in array ... Dim dbs As DAO.Database, rst As DAO.Recordset ... Dim var As Variant ...
    (microsoft.public.access.gettingstarted)
  • Re: Multiple OUs?
    ... something is up with adding multiple values to the array... ... ' If the AD enumeration runs into an OU object, call the Sub again to ... strLine = Trim ... strNewContents = strNewContents & strLine & vbCrLf ...
    (microsoft.public.scripting.vbscript)
  • Re: Packages and returning errors
    ... > array intact. ... sub is_a_instance_method { ... my $class = shift; ... You need to fix the scope of $error by moving its declaration outside ...
    (comp.lang.perl.misc)
  • Re: Updated datestamp doesnt work
    ... Public Sub StoreMyOldVals ... ' store values of current row in array ... Dim dbs As DAO.Database, rst As DAO.Recordset ... Dim var As Variant ...
    (microsoft.public.access.gettingstarted)
  • Re: Updated datestamp doesnt work
    ... Public Sub StoreMyOldVals ... ' store values of current row in array ... Dim dbs As DAO.Database, rst As DAO.Recordset ... Dim var As Variant ...
    (microsoft.public.access.gettingstarted)