[SRC] LoadRndNumericArray

[Psyke1]

Bueno, cómo ahora está de moda los numeros aleatorios encontré un hueco entre mis estudios y hice esto.
Soporta divrersos tipos de arrays...(Long, Byte, Integer...).
Uso la funcion de BlackZer0x :
http://goo.gl/RG4Bx
Tuve que cambiar un par de cosas nada más para adaptarlo.

Función:

Código (vb) [Seleccionar] Expandir


Option Explicit
'======================================================================
' º Function  : LoadRndNumericArray
' º Author    : Psyke1
' º Country   : Spain
' º Mail      : vbpsyke1@mixmail.com
' º Date      : 27/05/2011
' º Twitter   : http://twitter.com/#!/PsYkE1
' º Dedicated : BlackZer0x
' º Requirements : http://goo.gl/vgbtQ || http://goo.gl/BAPXx
' º Recommended Websites :
'       http://foro.h-sec.org
'       http://www.frogcheat.com.ar
'       http://InfrAngeluX.Sytes.Net
'======================================================================
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByVal Destination&, ByVal Source&, ByVal Length&)

Public Static Function LoadRndNumericArray(lngMin&, lngMax&, varOutPutArr, Optional varExceptionArr) As Boolean
Dim lngTotal&, lngFinalArr&(), lngRndIndex&, Q&, C&
   If IsArray(varOutPutArr) Then
       If lngMin < lngMax Then
           lngTotal = lngMax - lngMin
           C = 0
           
           If Not IsMissing(varExceptionArr) And IsArray(varExceptionArr) Then
               Start_QuickSort varExceptionArr '// With little mod.
               
               lngTotal = lngTotal - (UBound(varExceptionArr) - LBound(varExceptionArr) + 1)
               ReDim lngFinalArr&(0 To lngTotal)
               
               '// Fix repetitions and numbers out of range.
               For Q = lngMin To lngMax
                   If IsInArray(varExceptionArr, Q, , , , True) = -1 Then
                       lngFinalArr(C) = Q
                       C = C + 1
                   End If
               Next Q
           Else
               ReDim lngFinalArr&(0 To lngTotal)

               For Q = lngMin To lngMax
                   lngFinalArr(C) = Q
                   C = C + 1
               Next Q
           End If
           
           ReDim varOutPutArr(0 To lngTotal)
           Randomize Timer
           
           For Q = 0 To lngTotal
               lngRndIndex = Rnd * lngTotal
               varOutPutArr(Q) = lngFinalArr(lngRndIndex)
               
               RtlMoveMemory VarPtr(lngFinalArr(lngRndIndex)), VarPtr(lngFinalArr(lngRndIndex + 1)), (lngTotal - lngRndIndex) * &H4
               lngTotal = lngTotal - 1
           Next Q
           
           LoadRndNumericArray = True
       End If
   End If
End Function

Ejemplo:

Código (vb) [Seleccionar] Expandir

Option Explicit
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByVal Destination&, ByVal Source&, ByVal Length&)

Enum EnuListOrder
   AcendetOrder = 0
   DecendentOrder = 1
End Enum

Public Static Function LoadRndNumericArray(lngMin&, lngMax&, varOutPutArr, Optional varExceptionArr) As Boolean
Dim lngTotal&, lngFinalArr&(), lngRndIndex&, Q&, C&
   If IsArray(varOutPutArr) Then
       If lngMin < lngMax Then
           lngTotal = lngMax - lngMin
           C = 0
           
           If Not IsMissing(varExceptionArr) And IsArray(varExceptionArr) Then
               Start_QuickSort varExceptionArr
               
               lngTotal = lngTotal - (UBound(varExceptionArr) - LBound(varExceptionArr) + 1)
               ReDim lngFinalArr&(0 To lngTotal)
               
               '// Fix repetitions and numbers out of range.
               For Q = lngMin To lngMax
                   If IsInArray(varExceptionArr, Q, , , , True) = -1 Then
                       lngFinalArr(C) = Q
                       C = C + 1
                   End If
               Next Q
           Else
               ReDim lngFinalArr&(0 To lngTotal)

               For Q = lngMin To lngMax
                   lngFinalArr(C) = Q
                   C = C + 1
               Next Q
           End If
           
           ReDim varOutPutArr(0 To lngTotal)
           Randomize Timer
           
           For Q = 0 To lngTotal
               lngRndIndex = Rnd * lngTotal
               varOutPutArr(Q) = lngFinalArr(lngRndIndex)
               
               RtlMoveMemory VarPtr(lngFinalArr(lngRndIndex)), VarPtr(lngFinalArr(lngRndIndex + 1)), (lngTotal - lngRndIndex) * &H4
               lngTotal = lngTotal - 1
           Next Q
           
           LoadRndNumericArray = True
       End If
   End If
End Function

'   /////////////////////////////////////////////////////////////
'   // Autor Algoritmo: C.A.R. Hoare en 1960                   //
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////

Private Sub AuxOrden(ByRef mArray, i As Long, j As Long, il As Long, jl As Long)
Dim C                                       As String
Dim c2                                      As Long
   C = mArray(j)
   mArray(j) = mArray(i)
   mArray(i) = C
   c2 = il
   il = -jl
   jl = -c2
End Sub

Private Sub PreSort(ByRef mArray, lb As Long, ub As Long, k As Long, Optional Order As EnuListOrder = DecendentOrder)
Dim i                                       As Long
Dim j                                       As Long
Dim il                                      As Long
Dim jl                                      As Long
   il = 0: jl = -1
   i = lb: j = ub
   While i < j
       If Order = DecendentOrder Then
           If IsNumeric(mArray(i)) And IsNumeric(mArray(j)) Then
               If Val(mArray(i)) > Val(mArray(j)) Then
                   Call AuxOrden(mArray(), i, j, il, jl)
               End If
           Else
               If mArray(i) > mArray(j) Then
                   Call AuxOrden(mArray(), i, j, il, jl)
               End If
           End If
       Else
           If IsNumeric(mArray(i)) And IsNumeric(mArray(j)) Then
               If Val(mArray(i)) < Val(mArray(j)) Then
                   Call AuxOrden(mArray(), i, j, il, jl)
               End If
           Else
               If mArray(i) < mArray(j) Then
                   Call AuxOrden(mArray(), i, j, il, jl)
               End If
           End If
       End If
       i = i + il
       j = j + jl
   Wend
   k = i
End Sub

Private Sub QSort(ByRef mArray, lb As Long, ub As Long, _
               Optional Order As EnuListOrder = DecendentOrder)
Dim k                                   As Long
   If lb < ub Then
       PreSort mArray, lb, ub, k, Order
       Call QSort(mArray, lb, k - 1, Order)
       Call QSort(mArray, k + 1, ub, Order)
   End If
End Sub

Public Sub Start_QuickSort(ByRef mArray, Optional Order As EnuListOrder = DecendentOrder)
   QSort mArray, LBound(mArray), UBound(mArray), Order
End Sub

'// by Psyke1
Public Static Function IsInArray&(varArr, _
                                 varValue, _
                                 Optional lngStart&, _
                                 Optional lngEnd&, _
                                 Optional bolFindFirst As Boolean, _
                                 Optional bolIsSorted As Boolean)
Dim lngLB&, lngUB&, Q&, C&
   If (IsArray(varArr) = True) And (IsArray(varValue) = False) Then
       lngLB = LBound(varArr)
       lngUB = UBound(varArr)

       If Not IsMissing(lngStart) Then
          If (lngStart > lngLB) And (lngStart < lngUB) Then lngLB = lngStart
       End If
       If Not IsMissing(lngEnd) Then
          If (lngEnd > lngLB) And (lngEnd < lngUB) Then lngUB = lngEnd
       End If

       If bolIsSorted Then
           If varArr(lngLB) = varValue Then
               IsInArray = lngLB
               Exit Function
           ElseIf varArr(lngUB) = varValue Then
               If bolFindFirst Then
                   Do While (varArr(lngUB) = varArr(lngUB - 1)) And (Q > lngLB)
                       lngUB = lngUB - 1
                   Loop
               End If
               
               IsInArray = lngUB
               Exit Function
           End If

           If lngUB - lngLB < 2 Then GoTo NotFound
           If (varArr(lngLB) > varValue) Or (varArr(lngUB) < varValue) Then GoTo NotFound

           C = 0
           Do
               Q = (lngUB + lngLB) \ 2
               If C = Q Then GoTo NotFound
               
               If varArr(Q) > varValue Then
                   lngUB = Q
               ElseIf varArr(Q) < varValue Then
                   lngLB = Q
                   C = lngLB
               Else
                   If bolFindFirst Then
                       Do While (varArr(Q) = varArr(Q - 1)) And (Q > lngLB)
                           Q = Q - 1
                       Loop
                   End If
                   
                   IsInArray = Q
                   Exit Function
               End If
           Loop
       Else
           For Q = lngLB To lngUB
               If varArr(Q) = varValue Then
                   IsInArray = Q
                   Exit Function
               End If
           Next Q
           
           GoTo NotFound
       End If
   End If
Exit Function

NotFound:
   IsInArray = -1
End Function

Private Sub Form_Load()
Dim varItem, lngOut&(), intEx%(0 To 3)

   intEx(0) = -2
   intEx(1) = 1
   intEx(2) = 5
   intEx(3) = 8

   Debug.Print String$(40, "="), Time$

   If LoadRndNumericArray(-5, 10, lngOut, intEx) Then
       For Each varItem In lngOut
           Debug.Print varItem
       Next varItem
   End If
End Sub

Resultado:

Código [Seleccionar] Expandir

========================================  20:10:55
4
-4
7
3
9
-1
-5
0
10
2
6
-3

Voy a seguir estudiando para la selectividad... Bye

DoEvents!