<%
Sub Shuffle (ByRef arrInput)
'declare local variables:
Dim arrIndices, iSize, x
Dim arrOriginal
'calculate size of given array:
iSize = UBound(arrInput)+1
'build array of random indices:
arrIndices = RandomNoDuplicates(0, iSize-1, iSize)
'copy:
arrOriginal = CopyArray(arrInput)
'shuffle:
For x=0 To UBound(arrIndices)
arrInput(x) = arrOriginal(arrIndices(x))
Next
End Sub
Function CopyArray (arr)
Dim result(), x
ReDim result(UBound(arr))
For x=0 To UBound(arr)
If IsObject(arr(x)) Then
Set result(x) = arr(x)
Else
result(x) = arr(x)
End If
Next
CopyArray = result
End Function
Function RandomNoDuplicates (iMin, iMax, iElements)
'this function will return array with "iElements" elements, each of them is random
'integer in the range "iMin"-"iMax", no duplicates.
'make sure we won't have infinite loop:
If (iMax-iMin+1)>iElements Then
Exit Function
End If
'declare local variables:
Dim RndArr(), x, curRand
Dim iCount, arrValues()
'build array of values:
Redim arrValues(iMax-iMin)
For x=iMin To iMax
arrValues(x-iMin) = x
Next
'initialize array to return:
Redim RndArr(iElements-1)
'reset:
For x=0 To UBound(RndArr)
RndArr(x) = iMin-1
Next
'initialize random numbers generator engine:
Randomize
iCount=0
'loop until the array is full:
Do Until iCount>=iElements
'create new random number:
curRand = arrValues(CLng((Rnd*(iElements-1))+1)-1)
'check if already has duplicate, put it in array if not
If Not(InArray(RndArr, curRand)) Then
RndArr(iCount)=curRand
iCount=iCount+1
End If
'maybe user gave up by now...
If Not(Response.IsClientConnected) Then
Exit Function
End If
Loop
'assign the array as return value of the function:
RandomNoDuplicates = RndArr
End Function
Function InArray(arr, val)
Dim x
InArray=True
For x=0 To UBound(arr)
If arr(x)=val Then
Exit Function
End If
Next
InArray=False
End Function
'usage:
Dim arrTest
arrTest = Array(5, 8, 10, 15, 2, 30)
Call Shuffle(arrTest)
Response.Write(Join(arrTest, "<br />"))
%>