Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: Bazooka en Enero 31, 2011, 09:13:55 pm
-
Hola necesito una rutina si alguien tiene que me permita extraer todas las combinaciones posibles de una cadena de numeros pasados como parametros :
yo encontre esta pero es si bien hace lo que quiero es ineficiente por que solo trabaja con numeros chicos:
Option Explicit
Dim strRet() As String
Private Sub GetPermutation(ItemToPermeate As String, Optional RecursivePlaceHolder As String = "")
Dim i As Integer
Static intArr As Integer
Dim strWorkingChr As String
Dim strPlaceHolder As String
Dim strString As String
If Len(ItemToPermeate) Then 'Loop while you have something to work with
'work through each character in the string
For i = 1 To Len(ItemToPermeate)
strWorkingChr = Left(ItemToPermeate, i - 1)
strPlaceHolder = Mid(ItemToPermeate, i, 1)
strString = Mid(ItemToPermeate, i + 1)
'Get all the permutations for the string
Call GetPermutation(strWorkingChr & strString, RecursivePlaceHolder & strPlaceHolder)
Next i
Else
ReDim Preserve strRet(intArr)
strRet(intArr) = RecursivePlaceHolder
intArr = intArr + 1
End If
End Sub
Private Sub Command1_Click()
Dim i As Integer
GetPermutation "12345"
For i = 0 To UBound(strRet)
Debug.Print strRet(i)
Next i
MsgBox "Numero de permutacion " & UBound(strRet) + 1
End Sub
Alguien tiene algo mejor o mas escalable?
ME acabo de dar cuenta que esta no me sirve por que por ejemplo me devuelve combinaciones ordenadas distintos pero con los mismos numeros ej. 12345, 12354, 12543 y no es lo que busco...
Gracias
-
Al menos así funcionará mejor, creo:
Option Explicit
Private strRet() As String
Private Sub GetPermutation(ByRef strItem As String, Optional ByVal RecursivePlaceHolder As String)
Static lngArr As Long
Dim strWorkingChr As String
Dim strPlaceHolder As String
Dim strString As String
Dim lngLen As Long
Dim Q As Long
lngLen = LenB(strItem) \ 2
If lngLen Then
For Q = 1 To lngLen
strWorkingChr = Left$(strItem, Q - 1)
strPlaceHolder = Mid$(strItem, Q, 1)
strString = Mid$(strItem, Q + 1)
GetPermutation (strWorkingChr & strString), (RecursivePlaceHolder & strPlaceHolder)
Next Q
Else
ReDim Preserve strRet(lngArr)
strRet(lngArr) = RecursivePlaceHolder
lngArr = lngArr + 1
End If
End Sub
Private Sub Command1_Click()
Dim Q As Long
Dim lngLimit As Long
GetPermutation "12786987"
lngLimit = UBound(strRet)
Debug.Print String$(100, "=")
For Q = 0 To lngLimit
Debug.Print strRet(Q)
Next
MsgBox "Numero de permutacion " & CStr(lngLimit + 1)
End SubMañana hago una versión mía a ver si puedo ganar un poco de velocidad
Con redim preserve se gasta tieeeeeempo... :(
DoEvents! :P
-
Edit:No funciona, ahora no tengo tiempo, pero sería algo así:
Así más rápido:
Option Explicit
Private strRet() As Long
Private Function GetPermutation(ByVal strText As String, Optional ByRef RecursivePlaceHolder As String) As Boolean
Dim lngLen As Long
lngLen = LenB(strText) \ 2
If lngLen > 0 Then
ReDim strRet(CalcPossibilities(lngLen) - 1)
GetPerm strText, RecursivePlaceHolder
GetPermutation = True
End If
End Function
Private Function CalcPossibilities(ByVal lngNumber As Long) As Long
Dim Q As Long
CalcPossibilities = lngNumber
lngNumber = lngNumber - 1
For Q = lngNumber To 2 Step -1
CalcPossibilities = CalcPossibilities * Q
Next
End Function
Private Sub GetPerm(ByRef strItem As String, Optional ByRef RecursivePlaceHolder As String)
Static lngPos As Long
Dim strWorkingChr As String
Dim strPlaceHolder As String
Dim strString As String
Dim lngLen As Long
Dim Q As Long
lngLen = LenB(strItem) \ 2
If lngLen Then
For Q = 1 To lngLen
strWorkingChr = Left$(strItem, Q - 1)
strPlaceHolder = Mid$(strItem, Q, 1)
strString = Mid$(strItem, Q + 1)
GetPerm (strWorkingChr & strString), (RecursivePlaceHolder & strPlaceHolder)
Next Q
Else
strRet(lngPos) = CStr(RecursivePlaceHolder)
lngPos = lngPos + 1
End If
End Sub
Private Sub Command1_Click()
Dim Q As Long
Dim lngLimit As Long
If GetPermutation("1274") Then
Debug.Print String$(100, "=")
lngLimit = UBound(strRet)
For Q = 0 To lngLimit
Debug.Print strRet(Q)
Next
MsgBox "Numero de permutacion " & CStr(lngLimit + 1)
End If
End Sub
[code]
DoEvents! :P
-
Creo que hacer anagramas no te sirve (porque te da todas las combinaciones posibles al mas estilo BruteForce) que creo que es lo que hace la primera conbinacion.
Creo que deberias dar mas ejemplos, o al menos ciertas "reglas" para hacer las combinaciones
Option Explicit
Private Function CalcPossibilities(ByVal lngNumber As Long) As Long
Dim Q As Long
CalcPossibilities = lngNumber
lngNumber = lngNumber - 1
For Q = lngNumber To 2 Step -1
CalcPossibilities = CalcPossibilities * Q
Next
End Function
Lo que haces ahi es calcular el factorial, y funciona solo para números chicos (si no me equivoco no puedes llegar a 20 sin explotar ._.)
-
Si Raul tenes razon los probe con 123456789 y se quedo procesando un monton de tiempo y me genero algo asi como 320.880 combinaciones.
Perdon pero no entiendo lo de anagramas!
-
No creo que te salga MIKE. Vas a tener muuuuchas posibilidades por abarcar y seguramente no te compense el premio con todos los cartones que quieres comprar.
Suerte! ;)
DoEvents! :P
-
Te agradezco tu gentileza en colaborar con mi pedido . Pero no me parece que me entendiste mal!
Solo compre un carton y ni pienso comprar más!! Lo otro es solo que estoy emperrado en dilucidar como es el sistema de clave perfecta que utilizan esos bingos.
Ssluditos!!
-
mira mike la clave que usa san vicente se llaman claves perfectas y son computadas, de la unica manera que exciste un ganador es que la computadora pare el sorteo cuando hay un ganador, ademas esas calves se elige al azar x cantidad de numero y con esos se juegan, yo la llamaria secuencia de numeros, es mas fijate que en tu carton te faltan decenas, no juegan las 99 bolillas aunque esten en el bolillero, y ademas es muy fasil para el fraude, como sabes vos si es real que el ganador que ellos dicen es el verdadero, si te muestran una hoja que sacan en el monento de la pc.
-
.
espero no llegar tarde con lo de las permutaciones
Option Explicit
Private Sub Priv_GetPermutaciones(ByRef vData As String, ByRef ArrOuput() As String, ByRef lng_pos As Double, Optional ByRef strFixed As String)
Dim int_t As Integer
If Len(vData) <> 1 Then
For int_t = 1 To Len(vData)
Priv_GetPermutaciones Left$(vData, int_t - 1) & Mid$(vData, int_t + 1), ArrOuput(), lng_pos, strFixed & Mid$(vData, int_t, 1)
Next int_t
Else
ArrOuput(lng_pos) = strFixed & vData
lng_pos = lng_pos + 1
End If
End Sub
Public Function GetPermutaciones(ByRef vData As String, ByRef ArrOuput() As String) As Long
Dim lng_i As Long
Dim lng_buff As Double
lng_buff = 1
For lng_i = 1 To Len(vData)
lng_buff = lng_buff * lng_i
Next lng_i
ReDim ArrOuput(0 To lng_buff - 1)
Call Priv_GetPermutaciones(vData, ArrOuput(), 0)
GetPermutaciones = lng_buff
End Function
Private Sub Form_Load()
Dim str_Arr() As String
Dim lng_i As Long
For lng_i = 0 To GetPermutaciones("BlackZeroX", str_Arr()) - 1
Debug.Print str_Arr(lng_i)
Next lng_i
End Sub
Temibles Lunas!¡.
-
Hola felicitaciones y gracias por compartir en el foro BlackZeroX !! Me he tomado el atrevimiento de modificar un poco, y pude hacer un programita para conseguir las claves de redes wifi, wep, wpa personal, etc..
es uno de los tantos usos que le di..
saludos
-
Ala gra...... Pasate el proyecto ;D Serviria de mucho.... Se te agradeceria....
-
Podrias compartir Fernando
-
Hola felicitaciones y gracias por compartir en el foro BlackZeroX !! Me he tomado el atrevimiento de modificar un poco, y pude hacer un programita para conseguir las claves de redes wifi, wep, wpa personal, etc..
es uno de los tantos usos que le di..
saludos
Te vas a volver grande!!! solo tienes que pasar el codigo jejeje.
-
Creo que este tema rumbeó para otro lado!!!
Saluditos!!
-
Creo que este tema rumbeó para otro lado!!!
Saluditos!!
jajajjaja cierto!