Mensajes

numeros aleatorios sin repeticion?...

http://foro.elhacker.net/programacion_visual_basic/src_crndnumbersnr_generar_numeros_aleatorios_sin_repetir_veryfast-t328967.0.html

Dulces Lunas!¡.

http://foro.elhacker.net/programacion_visual_basic/source_cpushsort-t340133.0.html

Dulces Lunas!¡.

Por eso es OpenSource!¡.

Dulces Lunas!¡.

Minuto 1:38   ... podre animalito.

[youtube=425,350]http://www.youtube.com/watch?v=NrElZQ3ckM4&feature=related[/youtube]

Dulces Lunas!¡.

&HBD y &HDB

son numeros hezadecimales...

las constantes no me tarde ni 1 segundo al usar google y encontre esto de la msdn

http://msdn.microsoft.com/en-us/library/aa243025%28v=vs.60%29.aspx

Dulces Lunas!¡.

.
* Jamas uses los controles X como un amacen de datos... es algo que no se deberia de hacer; separa la parte grafica de la parte interna de tu programa...
* A razon de tu problema te dejo esta clase.

Quizas te sirva mi clase.
http://foro.elhacker.net/programacion_visual_basic/source_cpushsort-t340133.0.html

Dulces Lunas!¡.

.
Esta clase solo sive para agregar elementos y buscar dichos elementos de la manera ams rapida posible que con un simple array y un simple for next.

* Permite Agregar un array long (Se puede mejorar el algoritmo respecto a esto, pero lo deje asi.).
* Permite agregar Elementos Unicos en el momento que se desee.
* Retorna la posicion (IndexOf) si se encuentra de lo contrario retorna un valor constante INVALIDVALUEARRAY.
* Permite consultar X elemento ( GetElement).
* Permite eliminar X elemento segun su indice ( Remove(); posiblemente se tenga que buscar primero con IndexOf() ).
* Retorna la cantidad de elementos.
* Tiene una tasa de BUSQUEDA MUY RAPIDA.

Código (vb) [Seleccionar] Expandir



'
'   /////////////////////////////////////////////////////////////
'   //                                                         //
'   // 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                 //
'   /////////////////////////////////////////////////////////////

Option Explicit

Private lMem()          As Long
Private lCount          As Long
Private bDuplicate      As Boolean

Public Sub clear()
    Erase lMem()
    lCount = 0
End Sub

Public Property Get Count() As Long
    Count = lCount
End Property

'   //  Retorna la cantidad de elementos restantes.
Public Function Remove(ByVal lIndex As Long) As Long
    Remove = RemoveInArrayLong(lIndex, lMem())
End Function

Public Property Get DuplicateElements() As Boolean
    DuplicateElements = bDuplicate
End Property

Public Property Let DuplicateElements(ByVal bBool As Boolean)
    bDuplicate = bBool
End Property

'   //  Agrega un array a la coleccion y retorna la cantidad de elementos agregados a ella.
Public Function AddArray(ByRef lArray() As Long) As Long
Dim i                   As Long
Dim c                   As Long
    If Not (ItsArrayINI(VarPtrA(lArray))) Then Exit Function
    c = lCount
    For i = LBound(lArray()) To UBound(lArray())
        Me.Add lArray(i)
    Next
    AddArray = (lCount - c) '   //  Cantidad de elementos REALMENTE AGREGADOS: es igual a la direfencia del valor anterior y el actual de lCount.
End Function

'   //  Inserta en el Array el elemento Dado de manera Ascendente.
'   //  Agrega lVal en la coleccion de manera ordenada, y retorna el indice de su hubicacion.
'   //  Se retorna el indice de la hubicacion (...cambia este indice si se agrega otro y es menor a este...).
Public Function Add(ByVal lVal As Long) As Long
Dim lRetPos             As Long
    '   //  Buscamos la posicion en donde insertar...
    If ExitsInArray(lVal, lMem(), lRetPos) And Not bDuplicate Then Exit Function
    ReDim Preserve lMem(lCount)
    lCount = (lCount + 1)
    If ((lCount - 1) - lRetPos) Then '   //  Recorremos a la derecha TODOS los elementos.
        CopyMemory VarPtr(lMem(lRetPos + 1)), VarPtr(lMem(lRetPos)), ((lCount - lRetPos) * &H4)
    End If
    lMem(lRetPos) = lVal
    Add = lRetPos
End Function

'   //  Obtenemos una copia de la coleccion de elementos.
Public Function GetArray() As Long()
    GetArray = lMem()
End Function

Public Function IndexOf(ByVal lVal As Long) As Long
    If Not ExitsInArray(lVal, lMem, IndexOf) Then IndexOf = INVALIDVALUEARRAY
End Function

Public Function GetElement(ByVal lIndex As Long) As Long
    If (lIndex < lCount) Then GetElement = lMem(lIndex)
End Function

Private Function ExitsInArray(ByRef lVal As Long, ByRef lArray() As Long, ByRef lRetPos As Long) As Boolean
Dim lLIndex                 As Long
Dim lUIndex                 As Long
Dim iSortType               As Long

    If Not (ItsArrayINI(VarPtrA(lArray))) Then lRetPos = 0: Exit Function
   
    lLIndex = LBound(lArray())
    lUIndex = UBound(lArray())
   
    If (lArray(lUIndex) < lArray(lLIndex)) Then
        SwapLong lLIndex, lUIndex
        iSortType = 1
    End If

    If (lVal < lArray(lLIndex)) Then
        lRetPos = lLIndex
    ElseIf (lVal = lArray(lLIndex)) Then
        lRetPos = lLIndex
        ExitsInArray = True
    Else
        If (lVal > lArray(lUIndex)) Then
            lRetPos = lUIndex
        ElseIf (lVal = lArray(lUIndex)) Then
            lRetPos = lUIndex
            ExitsInArray = True
        Else
            Do Until ExitsInArray
                lRetPos = ((lLIndex + lUIndex) \ 2)
                If ((lRetPos <> lLIndex) And (lRetPos <> lUIndex)) Then
                    If (lArray(lRetPos) < lVal) Then
                        lLIndex = lRetPos
                    ElseIf (lArray(lRetPos) > lVal) Then
                        lUIndex = lRetPos
                    ElseIf (lArray(lRetPos) = lVal) Then
                        ExitsInArray = True
                    End If
                Else
                    Exit Do
                End If
            Loop
        End If
    End If
   
    If Not (ExitsInArray) Then              '   //  Obtenemos la posicion donde deberia estar dicho elemento.
        If (iSortType = 1) Then
            If (lArray(lRetPos) > lVal) Then lRetPos = (lRetPos - 1)
        Else
            If (lArray(lRetPos) < lVal) Then lRetPos = (lRetPos + 1)
        End If
    End If
   
End Function

Private Sub Class_Terminate()
    Call Me.clear
End Sub



En un Modulo...

Código (vb) [Seleccionar] Expandir



Option Explicit

Public Const INVALIDVALUEARRAY As Long = (-1)

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal ByteLen As Long)
Public Declare Function VarPtrA Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long

Public Function ItsArrayINI(ByVal lngPtr As Long, Optional LnBytes As Long = 4) As Boolean
Dim lng_PtrSA                   As Long
    If ((lngPtr <> 0) And (LnBytes > 0)) Then
        Call CopyMemory(ByVal VarPtr(lng_PtrSA), ByVal lngPtr, LnBytes)
        ItsArrayINI = (Not (lng_PtrSA = 0))
    End If
End Function

Public Sub SwapLong(ByRef lVal1 As Long, ByRef lval2 As Long)
    lval2 = lval2 Xor lVal1
    lVal1 = lVal1 Xor lval2
    lval2 = lval2 Xor lVal1
End Sub

'   //  Return (Cantidad de elementos).
Public Function RemoveInArrayLong(ByVal lIndex As Long, ByRef lArray() As Long) As Long
    If (ItsArrayINI(VarPtrA(lArray)) = True) Then
        RemoveInArrayLong = UBound(lArray)
        If Not ((lIndex < 0) Or (lIndex > RemoveInArrayLong)) Then
            If Not (lIndex = RemoveInArrayLong) Then
                Call CopyMemory(ByVal VarPtr(lArray(lIndex)), ByVal VarPtr(lArray(lIndex + 1)), (RemoveInArrayLong - lIndex) * 4)
            End If
            If ((RemoveInArrayLong - 1) > INVALIDVALUEARRAY) Then
                ReDim Preserve lArray(RemoveInArrayLong - 1)
            Else
                Erase lArray()
            End If
        End If
    End If
End Function



Temibles Lunas!¡.

[txtCell]

.
Optimise varias cosas...

[opcional]
El siguiente codigo requiere de un form con varios textbox llamados txtCell (matrix de controles) y un boton llamado cmdSolve, pongo en descarga el archivo para bajar.
[/opcional]

Código (Vb) [Seleccionar] Expandir



'
'   /////////////////////////////////////////////////////////////
'   // 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 engrandecido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Dim bSudoku(8, 8)   As Byte '   //  (nColumnas, nFilas)

'Private Sub cmdSolve_Click()
'    fillSudoku bSudoku
'    Caption = solveSudoku(bSudoku, 0, 0) '   //  Por BackTracking
'    showSudoku bSudoku
'End Sub

Private Sub Form_Load()
    bSudoku(0, 0) = 5
    bSudoku(0, 1) = 3
    bSudoku(0, 4) = 7

    bSudoku(1, 0) = 6
    bSudoku(1, 3) = 1
    bSudoku(1, 4) = 9
    bSudoku(1, 5) = 5

    bSudoku(2, 1) = 9
    bSudoku(2, 2) = 6
    bSudoku(2, 7) = 1

    bSudoku(3, 0) = 8
    bSudoku(3, 4) = 6
    bSudoku(3, 8) = 3

    bSudoku(4, 0) = 4
    bSudoku(4, 3) = 8
    bSudoku(4, 5) = 3
    bSudoku(4, 8) = 1

    bSudoku(5, 0) = 7
    bSudoku(5, 4) = 2
    bSudoku(5, 8) = 6

    bSudoku(6, 1) = 6
    bSudoku(6, 6) = 2
    bSudoku(6, 7) = 8

    bSudoku(7, 3) = 4
    bSudoku(7, 4) = 1
    bSudoku(7, 5) = 9
    bSudoku(7, 8) = 5

    bSudoku(8, 4) = 8
    bSudoku(8, 7) = 7
    bSudoku(8, 8) = 9
   
    Debug.Print "Matrix inicial."
    showSudoku bSudoku
    If solveSudoku(bSudoku, 0, 0) Then
        Debug.Print "Sudoku Resuelto"
        showSudoku bSudoku
    Else
        Debug.Print "No se puede resolver, revisa la matrix."
    End If
End Sub

Public Sub showSudoku(ByRef bArray() As Byte)
Dim i As Integer
Dim j As Integer
    Show
    For i = 0 To UBound(bArray, 1)          '   //  Fila
        For j = 0 To UBound(bArray, 2)      '   //  Columa
            'txtCell((i * 9) + j).Text = bArray(j, i)
            If (((j + &H1) Mod &H3) = &H0) Then
                Debug.Print bArray(j, i); "|";
            Else
                Debug.Print bArray(j, i);
            End If
        Next
        Debug.Print
        If (((i + &H1) Mod &H3) = &H0) Then Debug.Print String(32, "-")
    Next
End Sub

'Public Sub fillSudoku(ByRef bArray() As Byte)
'Dim i As Integer
'Dim j As Integer
'    Show
'    For i = 0 To UBound(bArray, 1)          '   //  Fila
'        For j = 0 To UBound(bArray, 2)      '   //  Columa
'            bArray(j, i) = txtCell((i * 9) + j).Text
'        Next
'    Next
'End Sub

Public Function chkRow(ByRef bArray() As Byte, ByVal lIndex As Long, ByVal lVal As Long) As Boolean
'   //  Revisa la existencia de lVal en una Fila (lIndex).
Dim i           As Long
    Do While (i < 8) And (chkRow = False)
        If (bArray(i, lIndex) = lVal) Then chkRow = True
        i = (i + &H1)
    Loop
End Function

Public Function chkCol(ByRef bArray() As Byte, ByVal lIndex As Long, ByVal lVal As Long) As Boolean
'   //  Revisa la existencia de lVal en una Columna (lIndex).
Dim i           As Long
    Do While (i < 8) And (chkCol = False)
        If (bArray(lIndex, i) = lVal) Then chkCol = True
        i = (i + &H1)
    Loop
End Function

Public Function chkRect(ByRef bArray() As Byte, ByVal lCol As Long, ByVal lRow As Long, ByVal lVal As Long) As Boolean
'   //  Revisa la existencia de lVal en el cuadrante desde la celda superior izquierda respectiva dados por (lCol, lRow).
Dim i           As Long
Dim j           As Long
    '   //  Obtenemos los indices de la celda superior izquierda del cuadrante inicial respectivo.
    lRow = ((lRow \ 3) * 3)
    lCol = ((lCol \ 3) * 3)
    Do          '   //  Filas
        j = &H0
        Do          '   //  Columnas
            If (bArray(lCol + j, lRow + i) = lVal) Then chkRect = True
            j = (j + &H1)
        Loop While (j < &H3) And (chkRect = False)
        i = (i + &H1)
    Loop While (i < &H3) And (chkRect = False)
End Function

Public Function solveSudoku(ByRef bArray() As Byte, ByVal lCol As Long, ByVal lRow As Long) As Boolean
'   //  Resuelve una Matrix de Sudoku de 9x9 celdas.
'   //  Si se retorna true, entonces la matrix ya esta Completa y/o Resuelta.
Dim lVal        As Long
Dim i           As Long

    '   //  Termino de filas.
    If (lRow >= 9) Then solveSudoku = True: Exit Function
   
    '   //  Nos posicionamos en la 1ra celda de lRow vacia (con valor 0).
    Do While Not (bArray(lCol, lRow) = &H0) And (solveSudoku = False)
        lCol = (lCol + &H1)
        If (lCol = &H9) Then
            lCol = &H0
            lRow = (lRow + &H1)
            If (lRow >= &H8) Then solveSudoku = True
        End If
    Loop
   
    '   //  Recorremos TODOS LOS VALORES desde 1 a 9 para la celda (lCol, lRow).
    For lVal = 1 To 9
        If Not chkRect(bArray, lCol, lRow, lVal) Then       '   //  Cuadro de 3x3.
            If Not (chkRow(bArray, lRow, lVal)) Then        '   //  Fila.
                If Not (chkCol(bArray, lCol, lVal)) Then    '   //  Columnas.
                    bArray(lCol, lRow) = lVal
                    If (lCol < 8) Then                      '   //  Aun no llegamos al final de la fila?
                        solveSudoku = solveSudoku(bArray, (lCol + 1), lRow)
                    Else                                    '   //  Iniciamos otra llamada si mismo pero en la siguiente fila
                        solveSudoku = solveSudoku(bArray, 0, (lRow + 1))
                    End If
                    If Not solveSudoku Then bArray(lCol, lRow) = 0  '   //  Seteamos la celda a 0 para realizar el BackTracking.
                End If
            End If
        End If
    Next
       
End Function



output:

Código [Seleccionar] Expandir



Matrix inicial.
5  6  0 | 8  4  7 | 0  0  0 |
3  0  9 | 0  0  0 | 6  0  0 |
0  0  6 | 0  0  0 | 0  0  0 |
--------------------------------
0  1  0 | 0  8  0 | 0  4  0 |
7  9  0 | 6  0  2 | 0  1  8 |
0  5  0 | 0  3  0 | 0  9  0 |
--------------------------------
0  0  0 | 0  0  0 | 2  0  0 |
0  0  1 | 0  0  0 | 8  0  7 |
0  0  0 | 3  1  6 | 0  5  9 |
--------------------------------
No se puede resolver, revisa la matrix.




con la matrix:

Código [Seleccionar] Expandir



    bSudoku(5, 0) = 5
    bSudoku(6, 0) = 2
   
    bSudoku(1, 1) = 6
    bSudoku(2, 1) = 5
    bSudoku(4, 1) = 3
   
    bSudoku(0, 2) = 9
    bSudoku(1, 2) = 3
    bSudoku(5, 2) = 1
   
    bSudoku(1, 3) = 9
    bSudoku(3, 3) = 4
    bSudoku(4, 3) = 6
    bSudoku(5, 3) = 3
   
    bSudoku(8, 4) = 8
   
    bSudoku(1, 5) = 7
    bSudoku(3, 5) = 8
    bSudoku(6, 5) = 6
   
    bSudoku(1, 6) = 8
    bSudoku(3, 6) = 1
    bSudoku(7, 6) = 3
    bSudoku(8, 6) = 2
   
    bSudoku(4, 7) = 8
    bSudoku(8, 7) = 4
   
    bSudoku(0, 8) = 5
    bSudoku(4, 8) = 9



Output:

Código [Seleccionar] Expandir



Matrix inicial.
0  0  0 | 0  0  5 | 2  0  0 |
0  6  5 | 0  3  0 | 0  0  0 |
9  3  0 | 0  0  1 | 0  0  0 |
--------------------------------
0  9  0 | 4  6  3 | 0  0  0 |
0  0  0 | 0  0  0 | 0  0  8 |
0  7  0 | 8  0  0 | 6  0  0 |
--------------------------------
0  8  0 | 1  0  0 | 0  3  2 |
0  0  0 | 0  8  0 | 0  0  4 |
5  0  0 | 0  9  0 | 0  0  0 |
--------------------------------
Sudoku Resuelto
1  4  8 | 6  7  5 | 2  9  3 |
2  6  5 | 9  3  8 | 4  1  7 |
9  3  7 | 2  4  1 | 8  5  6 |
--------------------------------
8  9  2 | 4  6  3 | 1  7  5 |
4  5  6 | 7  1  9 | 3  2  8 |
3  7  1 | 8  5  2 | 6  4  9 |
--------------------------------
6  8  9 | 1  2  7 | 5  3  2 |
7  1  3 | 5  8  4 | 9  6  4 |
5  2  4 | 3  9  6 | 7  8  1 |
--------------------------------



Temibles Lunas!¡.

JAJAJA pense que nadie lo hiba a notar xP... ya lo corrijo.

Dulces Lunas!¡.

mmm pon pixeles claves... algo asi lo haria...



Dulces Lunas!¡.