LaVolpe
Oct 6th, 2008, 07:11 PM
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
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