VB6 - Generic Array Shuffle

[LaVolpe]

This may exist elsewhere but I haven't seen it.
I was just thinking to myself, it would be nice to have a short, simple Shuffle routine for any array, whether the array contained strings, longs, dates, UDTs, classes, variants, whatever.

Well, being familiar with VB arrays and slick use of CopyMemory, we can create one routine that will shuffle an array for nearly all data types with minimal effort for the user.

The following function & sample code can be copied & pasted into a new project, just add a Command1 button. If you'd like to play with the array class example, just read the remarks in the command1_click below.

Option Explicit
' required for ShuffleAnyArray
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Type testUDT ' for demo only
    L As Long
    I As Integer
    B As Byte
    S As String
    ss As String * 5
End Type

Private Sub ShuffleAnyArray(ByVal VarPtr1stItem As Long, _
                            ByVal VarPtrLastItem As Long, _
                            ByVal NumberItems As Long, _
                            Optional ByVal ShuffleIterations As Long = 1&)
    ' Parameters:
    ' VarPtr1stItem entered as VarPtr(myArray([1stElementIndexToBeShuffled]))
    ' VarPtrLastItem entered as VarPtr(myArray([LastElementIndexToBeShuffled])
    ' NumberItems is total number of inclusive indexes between VarPtr1stItem & VarPtrLastItem
    ' ShuffleIterations is number of times the array is shuffled
    ' Example: If myArray were dimensioned as myArray(0 to 20) then
    '           ShuffleAnyArray VarPtr(myArray(0)), VarPtr(myArray(20)), 21
    ' Note: You do not have to shuffle the entire array, you can shuffle part of the
    '       array but the indexes to be shuffled must be consecutive
    ' Example: ShuffleAnyArray VarPtr(myArray(5)), VarPtr(myArray(15)), 11
    
    ' Warning: passing invalid NumberItems or ignoring following restrictions can cause application crash
    
    ' Array restrictions:
    ' 1. Must be single dimensional array, not multidimensional
    ' 2. Must not be a static string array, i.e., not like Dim myStrings(10) As String * 255
    ' 3. Must not be a control array, i.e., not VB controls (pictureboxes, textboxes, etc)
    ' 4. Otherwise, array can be: any VB data type, UDTs, and/or Classes
                            
    Dim arrIndex As Long        ' VarPtr indexes
    Dim shufflePtr As Long      ' Random VarPtr index
    Dim swapData() As Byte      ' Data to be swapped
    Dim elemBytes As Long       ' Data bytes between sequential indexes
    
    If NumberItems < 2& Then Exit Sub
    If ShuffleIterations < 1& Then Exit Sub

    ' calculate number of databytes between each VarPtr index
    elemBytes = (VarPtrLastItem - VarPtr1stItem) / (NumberItems - 1&)
    If elemBytes > 0& Then ' can be negative if passing Static String array or VB Control Array (i.e., Textboxes)
    
        ReDim swapData(0& To elemBytes - 1&)    ' size a swap buffer
        For ShuffleIterations = 1& To ShuffleIterations
            ' loop thru each VarPtr
            For arrIndex = VarPtr1stItem To VarPtrLastItem Step elemBytes
                ' get a random VarPtr index to swap with arrIndex
                shufflePtr = (Int(Rnd * NumberItems)) * elemBytes + VarPtr1stItem
                If Not shufflePtr = arrIndex Then ' else we'd just copy the same data in the same position
                    CopyMemory swapData(0), ByVal arrIndex, elemBytes         ' cache data @ arrIndex
                    CopyMemory ByVal arrIndex, ByVal shufflePtr, elemBytes    ' copy data from shufflePtr to arrIndex
                    CopyMemory ByVal shufflePtr, swapData(0), elemBytes       ' copy cached data to shufflePtr
                End If
            Next
        Next
    End If
End Sub

Private Sub Command1_Click()

    Const nrItems As Integer = 30
    ' for this exercise, nrItems must be =>4
    
    ' works with classes too.  If you wish to experiment with a class....
    ' 1. Create a new class in your project, name it Class1
    ' 2. Copy and add following 7 lines of code to the class, then remove the remark symbols (')
    '    Private m_Value As Long
    '
    '    Public Property Let Value(ByVal theValue As Long)
    '        m_Value = theValue
    '    End Property
    '    Public Property Get Value() As Long
    '        Value = m_Value
    '    End Property
    ' 3. UnRem the below code with clsArray references

    Dim intArray() As Integer       ' 2 bytes per array element
    Dim dtArray() As Date           ' 8 bytes per array element
    Dim strArray() As String        ' variant length strings, 4 bytes per elment (elements are StrPtrs)
    Dim udtArray() As testUDT       ' variant length (elements are multi-byte)
    Dim varArray() As Variant       ' variant, 16 bytes per element (elements can be anything: data, ObjPtr, StrPtr, GUID, etc)
'    Dim clsArray() As Class1        ' object, 4 bytes per element (elements are ObjPtrs)
    
    Dim X As Integer
    ReDim intArray(1 To nrItems) As Integer
    ReDim dtArray(1 To nrItems) As Date
    ReDim strArray(1 To nrItems) As String
    ReDim udtArray(1 To nrItems) As testUDT
    ReDim varArray(1 To nrItems) As Variant
'    ReDim clsArray(1 To nrItems) As Class1
    
    ' for this exercise, initialize array items in ascending order
    ' so when array is shuffled you can easily see it was shuffled
    For X = 1 To nrItems
        intArray(X) = X
        dtArray(X) = DateAdd("d", X, Date)
        strArray(X) = "Item " & X
        udtArray(X).L = X
        varArray(X) = X
'        Set clsArray(X) = New Class1
'        clsArray(X).Value = X
    Next
    varArray(nrItems \ 4) = "Apple"     ' mix up variants a bit
    varArray(nrItems \ 3) = "Banana"   ' combining longs & strings
    varArray(nrItems \ 2) = "Pear"
'    Set clsArray(nrItems \ 2) = Nothing ' throw an uninitialized class in the mix
    
    ' shuffle each type of array
    ShuffleAnyArray VarPtr(intArray(1)), VarPtr(intArray(nrItems)), nrItems
    ShuffleAnyArray VarPtr(dtArray(1)), VarPtr(dtArray(nrItems)), nrItems
    ShuffleAnyArray VarPtr(strArray(1)), VarPtr(strArray(nrItems)), nrItems
    ShuffleAnyArray VarPtr(udtArray(1)), VarPtr(udtArray(nrItems)), nrItems
    ShuffleAnyArray VarPtr(varArray(1)), VarPtr(varArray(nrItems)), nrItems
'    ShuffleAnyArray VarPtr(clsArray(1)), VarPtr(clsArray(nrItems)), nrItems
    
    ' output the results to the debug window
    For X = 1 To nrItems
        Debug.Print intArray(X);: Next
    Debug.Print
    For X = 1 To nrItems
        Debug.Print dtArray(X);: Next
    Debug.Print
    For X = 1 To nrItems
        Debug.Print strArray(X); " ";: Next
    Debug.Print
    For X = 1 To nrItems
        Debug.Print udtArray(X).L;: Next
    Debug.Print
    For X = 1 To nrItems
        Debug.Print varArray(X); " ";: Next
    Debug.Print
'    For X = 1 To nrItems
'        If clsArray(X) Is Nothing Then
'            Debug.Print " Nothing ";
'        Else
'            Debug.Print clsArray(X).Value;
'        End If
'    Next
'    Debug.Print
    
End Sub

[Merri]

I think it would be safer to pass the pointer to safearrayheader than pointers to variables. This way you can do all the safety checks relatively easily.

For a sample of a different technique and approach here is a generic array reverse function:

Option Explicit

Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Any)
Private Declare Sub GetMem8 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Any)
Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long)

Public Function ArrayReverse(ByVal NotNotArray As Long) As Boolean
    Dim lngA As Long, lngTemp(1) As Long, strTemp As String
    Dim intHeader(0 To 1) As Integer, lngHeader(0 To 3) As Long, lngLen As Long, lngPos As Long, strRev As String
    ' IDE error fix (this will not be compiled)
    Debug.Assert App.hInstance
    ' now see if we got anything
    If NotNotArray Then
        ' get header information
        GetMem4 NotNotArray, intHeader(0)
        ' only allow one dimension
        If intHeader(0) = 1 Then
            ' get more header information
            GetMem8 NotNotArray + 12, lngHeader(2)
            ' see if any data exists
            If lngHeader(2) Then
                ' data size information and lock status
                GetMem8 NotNotArray + 4, lngHeader(0)
                ' not locked?
                If lngHeader(1) = 0 Then
                    lngLen = lngHeader(0) * lngHeader(3)
                    ' must have length
                    If lngLen > 0 Then
                        ' remember old data, replace it temporarily with string length
                        GetMem4 lngHeader(2) - 4, lngTemp(0)
                        PutMem4 lngHeader(2) - 4, lngLen
                        ' remember old data, replace it temporarily with string terminator
                        GetMem4 lngHeader(2) + lngLen, lngTemp(1)
                        PutMem4 lngHeader(2) + lngLen, 0
                        ' fake string
                        PutMem4 VarPtr(strRev), lngHeader(2)
                        ' check size...
                        If lngHeader(0) = 2 Then
                            ' use StrReverse because it is optimized
                            MidB$(strRev, 1, lngLen) = StrReverse(strRev)
                        Else
                            ' last item
                            lngPos = lngLen + 1 - lngHeader(0)
                            strTemp = LeftB$(strRev, lngHeader(0))
                            ' reverse
                            For lngA = 1 To lngLen \ 2 + 1 - lngHeader(0) Step lngHeader(0)
                                MidB$(strTemp, 1, lngHeader(0)) = MidB$(strRev, lngPos, lngHeader(0))
                                MidB$(strRev, lngPos, lngHeader(0)) = MidB$(strRev, lngA, lngHeader(0))
                                MidB$(strRev, lngA, lngHeader(0)) = strTemp
                                lngPos = lngPos - lngHeader(0)
                            Next lngA
                        End If
                        ' end string faking
                        PutMem4 VarPtr(strRev), 0
                        ' restore old data
                        PutMem4 lngHeader(2) - 4, lngTemp(0)
                        PutMem4 lngHeader(2) + lngLen, lngTemp(1)
                        ' true on success
                        ArrayReverse = True
                    End If
                End If
            End If
        End If
    End If
End Function

And of course a sample to show it works:

Option Explicit

Private Sub Form_Load()
    Dim strTest() As String, intTest() As Integer
    ReDim strTest(4)
    strTest(0) = "A"
    strTest(1) = "B"
    strTest(2) = "C"
    strTest(3) = "D"
    strTest(4) = "E"
    If ArrayReverse(Not Not strTest) Then
        MsgBox Join(strTest)
    Else
        MsgBox "Array reverse on string array failed!"
    End If
    
    ReDim intTest(3)
    intTest(0) = 1
    intTest(1) = 2
    intTest(2) = 3
    intTest(3) = 4
    If ArrayReverse(Not Not intTest) Then
        MsgBox intTest(0) & intTest(1) & intTest(2) & intTest(3)
    Else
        MsgBox "Array reverse on integer array failed!"
    End If
End Sub

It should be pretty fast too, although it could be optimized further.

[Ellis Dee]

Your shuffling algorithm is biased. The correct method is to swap each element with a random selection of the remaining elements, including the current one.

More information can be found in this thread. It is worth reading from start to finish.