VBA Vector Classes

Posted on | September 2, 2008 | 17:36 | 7 comments

If you’re anything like me and ever had to code anything in Visual Basic for Applications, you must have felt the need for a proper API with some very basic common ADTs. The most basic of them being, in my opinion, the dynamic array (Vector, ArrayList, List and Collection are often used more or rather less synonymous). So what would it feel like to be able to write this and have it work?

Dim primitiveVector As clsVector
Set primitiveVector = New clsVector
Dim myInt As Integer
myInt = 3
 
primitiveVector.AddItem myInt

There are of course other people who have made such a thing, and there’s the VBA Collection, but none of them quite fit what I wanted. I wanted a Vector that had random access, was able to handle LIFO and FIFO (and thus act as stack and queue), addition and insertion and deletion, could check for item existence, and had dynamic resizing. So I went and coded my own. I did this while working at Promino AG and thus the code is technically theirs, so thanks to Paul Moser for the nod for publishing this under the GNU Lesser General Public License.

You can download both classes (two? more below), together with a tiny trivial testing framework, as Access 2002-2003 .mdb.

This here is the vector class for Variants. It goes into a new class module, I called mine “clsVector”:

Option Compare Database
Option Explicit
 
' Copyright 2007, 2008 by Promino AG
' Author: Guido Gloor
'
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU Lesser General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public License
' along with this program.  If not, see <http://www.gnu.org/licenses/>.

Private itemCount As Integer
Private itemBufferSize As Integer
Private itemBuffer() As Variant
 
Private Sub Class_Initialize()
    itemCount = 0
    itemBufferSize = 100
    NewDimensions
End Sub
 
Private Sub NewDimensions()
    ReDim Preserve itemBuffer(itemBufferSize) As Variant
End Sub
 
Private Sub CheckDimensions()
    If itemCount > itemBufferSize - 2 Then
        itemBufferSize = itemBufferSize * 2
        NewDimensions
    End If
End Sub
 
Public Sub ShrinkDimensions()
    itemCount = itemBufferSize + 10
    NewDimensions
End Sub
 
Public Function GetSize() As Integer
    GetSize = itemCount
End Function
 
Public Sub AddItem(item As Variant)
    CheckDimensions
    itemBuffer(itemCount) = item
    itemCount = itemCount + 1
End Sub
 
Public Function GetItem(index As Integer) As Variant
    GetItem = itemBuffer(index)
End Function
 
Public Function PopItem() As Variant
    PopItem = itemBuffer(itemCount - 1)
    DeleteItem itemCount - 1
End Function
 
Public Function GetNextQueueItem() As Variant
    GetNextQueueItem = itemBuffer(0)
    DeleteItem 0
End Function
 
Public Function ContainsItem(item As Variant) As Boolean
    Dim i As Integer
    ContainsItem = False
 
    For i = 0 To itemCount - 1
        If itemBuffer(i) = item Then ContainsItem = True
    Next i
End Function
 
Public Sub InsertItem(index As Integer, item As Variant)
    Dim i As Integer
 
    CheckDimensions
    For i = itemCount - 1 To index Step -1
        itemBuffer(i + 1) = itemBuffer(i)
    Next i
    itemBuffer(index) = item
    itemCount = itemCount + 1
End Sub
 
Public Sub DeleteItem(index As Integer)
    Dim i As Integer
 
    For i = index + 1 To itemCount - 1
        itemBuffer(i - 1) = itemBuffer(i)
    Next i
    itemCount = itemCount - 1
End Sub
 
Public Function IsEmpty() As Boolean
    IsEmpty = itemCount <= 0
End Function

Now, it would be nice if we would be done. But, we’re not done yet, obviously, after all there’s plenty more code below this break. The reason for that is simple: In VBA, a Variant is not an Object, and an Object is not a Variant, consequently functions that take Objects don’t take Variants and vice versa (although you can technically store an Object in a Variant, this will lead to problems). Objects also happen to have “Set” mandatory in places where it isn’t allowed for Variants.

What this means is that there is no way to have the same Vector class for both your custom ADTs and the primitive data types. So basically, we have another class that has exactly the same functions and exactly the same algorithms, but takes Objects instead of Variants. I called mine “clsObjectVector”. Here is the source for the class module:

Option Compare Database
Option Explicit
 
' Copyright 2007, 2008 by Promino AG
' Author: Guido Gloor
'
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU Lesser General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
'
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU Lesser General Public License for more details.
'
' You should have received a copy of the GNU Lesser General Public License
' along with this program.  If not, see <http://www.gnu.org/licenses/>.

Private itemCount As Integer
Private itemBufferSize As Integer
Private itemBuffer() As Object
 
Private Sub Class_Initialize()
    itemCount = 0
    itemBufferSize = 100
    NewDimensions
End Sub
 
Private Sub NewDimensions()
    ReDim Preserve itemBuffer(itemBufferSize) As Object
End Sub
 
Private Sub CheckDimensions()
    If itemCount > itemBufferSize - 2 Then
        itemBufferSize = itemBufferSize * 2
        NewDimensions
    End If
End Sub
 
Public Sub ShrinkDimensions()
    itemCount = itemBufferSize + 10
    NewDimensions
End Sub
 
Public Function GetSize() As Integer
    GetSize = itemCount
End Function
 
Public Sub AddItem(item As Object)
    CheckDimensions
    Set itemBuffer(itemCount) = item
    itemCount = itemCount + 1
End Sub
 
Public Function GetItem(index As Integer) As Object
    Set GetItem = itemBuffer(index)
End Function
 
Public Function PopItem() As Object
    Set PopItem = itemBuffer(itemCount - 1)
    DeleteItem itemCount - 1
End Function
 
Public Function GetNextQueueItem() As Object
    Set GetNextQueueItem = itemBuffer(0)
    DeleteItem 0
End Function
 
Public Function ContainsItem(item As Object) As Boolean
    ' The used ADTs need to have an Equals function for this to work
    Dim i As Integer
    ContainsItem = False
 
    For i = 0 To itemCount - 1
        If itemBuffer(i).Equals(item) Then ContainsItem = True
    Next i
End Function
 
Public Sub InsertItem(index As Integer, item As Object)
    Dim i As Integer
 
    CheckDimensions
    For i = itemCount - 1 To index Step -1
        Set itemBuffer(i + 1) = itemBuffer(i)
    Next i
    Set itemBuffer(index) = item
    itemCount = itemCount + 1
End Sub
 
Public Sub DeleteItem(index As Integer)
    Dim i As Integer
 
    For i = index + 1 To itemCount - 1
        Set itemBuffer(i - 1) = itemBuffer(i)
    Next i
    itemCount = itemCount - 1
End Sub
 
Public Function IsEmpty() As Boolean
    IsEmpty = itemCount <= 0
End Function

This is it, have fun As much as you can have if you’re forced to work with VBA, that is.

Oh, and if you can use it – comments are appreciated

Possibly similar posts (autogenerated):

Comments

7 Responses to “VBA Vector Classes”

Chunyang
May 18th, 2011 @ 12:26

For some reason, I want to have an input array.Something that like that:

Public Sub Get_From_Array(a() As Variant)

Dim item As Variant
Dim item_in As Variant

For Each item In a
AddItem (item_in)
Next item

End Sub

However, this won’t work out. Type mismatch error is shown when I try to call the method.

Anyway, thanks a lot for this module, it is very helpful for me. And VBA is very, very, very bad, to be honest.
Chunyang
May 18th, 2011 @ 12:27

Public Sub Get_From_Array(a() As Variant)

Dim item As Variant
Dim item_in As Variant

For Each item In a
item_in = item
AddItem (item_in)
Next item

End Sub
Guido
May 18th, 2011 @ 12:41

Are you using ClsObjectVector for this method? Type mismatch sounds like the Set command isn’t used where it should, or vice versa – that was why two classes were necessary…

If that doesn’t help, I must admit that I’m quite confused, too; haven’t coded much VBA lately, I’ve been able to avoid it for the most part :p
Chunyang
May 18th, 2011 @ 14:54

In fact, these two functions are sufficient, and they are safe.

Public Sub Get_From_Array(ByRef a() As Variant)

Dim item As Variant
For Each item In a
AddItem (item)
Next item

End Sub

Public Sub set_element(i As Integer, a As Variant)

itemBuffer(i) = a

End Sub

VBA syntax is awkard, for example, you should call

vec.Get_From_Array a ‘ a is an array

instead of

vec.Get_From_Array(a) ‘ which is wrong.
Chunyang
May 18th, 2011 @ 15:02

Thank you Guido.

I was wrong just where I said that VBA was awkard.
Guido
May 18th, 2011 @ 15:15

Heh, I’m not so sure about you being wrong – I think VBA syntax is very awkward indeed, downright horrible
Chunyang
May 18th, 2011 @ 17:22

I don’t know. Anyway,

vec.Get_From_Array a ‘ a is an array

works.

vec.Get_From_Array(a) ‘ a is an array

doesn’t.

By the way, I think that “the best” way to call a VBA function is to use:

f(a:=arr)

that is

vec.Get_From_Array(arr:=a) ‘ a is an array

haslo.ch – Guido’s Blog

We believe that people with passion can change the world for the better.

VBA Vector Classes

Comments

Search

Recent Posts

Categories

Tag Cloud

Feeds & Stuff