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/RG4BxTuve que cambiar un par de cosas nada más para adaptarlo.
Función:
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:
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:
======================================== 20:10:55
4
-4
7
3
9
-1
-5
0
10
2
6
-3
Voy a seguir estudiando para la selectividad...
Bye
DoEvents!
Mostrar Mensajes
