elhacker.net cabecera Bienvenido(a), Visitante. Por favor Ingresar o Registrarse
¿Perdiste tu email de activación?.

 

 


Tema destacado: Guía actualizada para evitar que un ransomware ataque tu empresa


  Mostrar Temas
Páginas: 1 2 3 4 5 6 7 8 9 10 [11] 12 13 14
101  Programación / Programación Visual Basic / * [Source] HexAndStringt (Version Very-Faster) en: 7 Enero 2010, 01:15 am
No se que hacer mas me he puesto a mejorar códigos así que pongo esta función es una función realmente rápida a comparación a las que se encuentran en google, así que pueden Encryptar y/o descifrar miles de MEGAS sin perder velocidad ya que los códigos que se encuentran en google pierden velocidad de descifrado en el acto.

Código
  1.  
  2. '
  3. ' ////////////////////////////////////////////////////////////////
  4. ' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
  5. ' //                                                            //
  6. ' // Web: http://InfrAngeluX.Sytes.Net/                         //
  7. ' //                                                            //
  8. ' // |-> Pueden Distribuir Este Código siempre y cuando         //
  9. ' // no se eliminen los créditos originales de este código      //
  10. ' // No importando que sea modificado/editado o engrandecido    //
  11. ' // o achicado, si es en base a este código                    //
  12. ' ////////////////////////////////////////////////////////////////
  13.  
  14. Option Explicit
  15. Enum ActionsHexStr
  16.    HexToString = 0
  17.    StringToHex
  18. End Enum
  19. Public Function HexAndString(ByVal vData As String, Optional Accion As ActionsHexStr = HexToString) As String
  20. Dim LenBuffer               As Long
  21. Dim LenOfBuffer             As Integer
  22. Dim Puntero                 As Long
  23. Dim I                       As Long
  24. Dim vStep                   As Integer
  25.    If CBool(IIf(Accion = HexToString And (Len(vData) Mod 2) = 0, True, IIf(Accion = StringToHex, True, False))) Then
  26.        LenBuffer = IIf(Accion = HexToString, Len(vData) / 2, Len(vData) * 2)
  27.        LenOfBuffer = IIf(Accion = HexToString, 1, 2)
  28.        HexAndString = Space(LenBuffer)
  29.        vStep = IIf(Accion = HexToString, 2, 1)
  30.        Puntero = 1
  31.        For I = 1 To Len(vData) Step vStep
  32.            If Accion = HexToString Then
  33.                Mid(HexAndString, Puntero, LenOfBuffer) = Chr$(Val("&H" & Mid$(vData, I, 2)))
  34.                Puntero = Puntero + 1
  35.            Else
  36.                Mid(HexAndString, Puntero, LenOfBuffer) = Hex$(Asc(Mid$(vData, I, 1)))
  37.                Puntero = Puntero + 2
  38.            End If
  39.        Next I
  40.    End If
  41. End Function
  42.  
  43.  

P.D.: Estoy aburrido me ire a jugar basketball nos vemos!¡.

Dulces Lunas!¡
102  Programación / Programación Visual Basic / * [Source] Triangulo Pascal en: 3 Enero 2010, 22:36 pm
bueno andaba aburrido e hice el codigo para generar el triangulo de pascal

se nesesitan

2 textBox (textbox 2 en propiedad multilinea = true)
1 CommandButton

Código
  1.  
  2. '
  3. ' ////////////////////////////////////////////////////////////////
  4. ' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
  5. ' //                                                            //
  6. ' // Web: http://InfrAngeluX.Sytes.Net/                         //
  7. ' //                                                            //
  8. ' // |-> Pueden Distribuir Este Codigo siempre y cuando         //
  9. ' // no se eliminen los creditos originales de este codigo      //
  10. ' // No importando que sea modificado/editado o engrandesido    //
  11. ' // o achicado, si es en base a este codigo                    //
  12. ' ////////////////////////////////////////////////////////////////
  13.  
  14. Option Explicit
  15.  
  16. Public Function GenerateTrianglePascal(ByVal nLineas As Long) As String
  17. On Error GoTo 1
  18. Dim a                       As Long
  19. Dim b                       As Long
  20. Dim CelVar()                As Double
  21.    If nLineas > 0 Then
  22.        ReDim CelVar(nLineas, nLineas)
  23.        For a = 1 To nLineas
  24.            For b = 1 To a: DoEvents
  25.                CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
  26.                GenerateTrianglePascal = GenerateTrianglePascal & CelVar(a, b) & IIf(Not b = a, String(3, " "), "")
  27.            Next b
  28.            If a <> nLineas Then GenerateTrianglePascal = GenerateTrianglePascal & vbCrLf
  29.        Next a
  30. 1:      Erase CelVar
  31.    End If
  32. End Function
  33.  
  34. Private Sub Form_Load()
  35.    Text2.Alignment = 2 '   //  Modo centralizado
  36. End Sub
  37.  
  38. Private Sub Command1_Click()
  39.    Text2.Text = GenerateTrianglePascal(Val(Text1.Text))
  40. End Sub
  41.  
  42.  

con dowhile y doevents

Código
  1.  
  2. '
  3. ' ////////////////////////////////////////////////////////////////
  4. ' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
  5. ' //                                                            //
  6. ' // Web: http://InfrAngeluX.Sytes.Net/                         //
  7. ' //                                                            //
  8. ' // |-> Pueden Distribuir Este Codigo siempre y cuando         //
  9. ' // no se eliminen los creditos originales de este codigo      //
  10. ' // No importando que sea modificado/editado o engrandesido    //
  11. ' // o achicado, si es en base a este codigo                    //
  12. ' ////////////////////////////////////////////////////////////////
  13.  
  14. Option Explicit
  15.  
  16. Public Function GenerateTrianglePascal(ByVal nLineas As Long) As String
  17. On Error GoTo 1
  18. Dim a                           As Long
  19. Dim b                           As Long
  20. Dim CelVar()                    As Double
  21.    If nLineas > 0 Then
  22.        ReDim CelVar(nLineas, nLineas)
  23.        a = 1: Do While a <= nLineas
  24.            b = 1: Do While b <= a: DoEvents
  25.                CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
  26.                GenerateTrianglePascal = GenerateTrianglePascal & CelVar(a, b) & IIf(Not b = a, String(2, " "), "")
  27.            b = b + 1: Loop
  28.            If a <> nLineas Then GenerateTrianglePascal = GenerateTrianglePascal & vbCrLf
  29.        a = a + 1: Loop
  30. 1:      Erase CelVar
  31.    End If
  32. End Function
  33.  
  34. Private Sub Form_Load()
  35.    Text2.Alignment = 2 '   //  Modo centralizado
  36. End Sub
  37.  
  38. Private Sub Command1_Click()
  39.    Text2.Text = GenerateTrianglePascal(Val(Text1.Text))
  40. End Sub
  41.  
  42.  


Código ligeramente mejorado ya se se queda tanto tiempo muerto!¡.

Código
  1.  
  2. '
  3. ' ////////////////////////////////////////////////////////////////
  4. ' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
  5. ' //                                                            //
  6. ' // Web: http://InfrAngeluX.Sytes.Net/                         //
  7. ' //                                                            //
  8. ' // |-> Pueden Distribuir Este Codigo siempre y cuando         //
  9. ' // no se eliminen los creditos originales de este codigo      //
  10. ' // No importando que sea modificado/editado o engrandesido    //
  11. ' // o achicado, si es en base a este codigo                    //
  12. ' ////////////////////////////////////////////////////////////////
  13.  
  14. Option Explicit
  15.  
  16. Public Sub GenerateTrianglePascal(ByVal nLineas As Long, ByRef OutData As String)
  17. 'On Error GoTo 1
  18. Dim a                       As Long
  19. Dim b                       As Long
  20. Dim Puntero                 As Long
  21. Dim Longitud                As Long
  22. Dim Temporal                As String
  23. Dim CelVar()                As Double
  24. Dim OutDataTemp             As String
  25. Const KiloByte              As Long = 5120
  26.    If nLineas > 0 Then
  27.        ReDim CelVar(nLineas, nLineas)
  28.        Puntero = 1
  29.        OutDataTemp = Space(KiloByte)
  30.        Temporal = Space(255)
  31.        For a = 1 To nLineas
  32.            For b = 1 To a: DoEvents
  33.                CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
  34.                Temporal = CelVar(a, b) & IIf(a <> b, " ", "")
  35.                Longitud = Len(Temporal)
  36.                Mid(OutDataTemp, Puntero, Longitud) = Temporal
  37.                Puntero = Puntero + Longitud
  38.                If Puntero > KiloByte Then
  39.                    OutData = OutData & OutDataTemp
  40.                    OutDataTemp = Space(KiloByte)
  41.                    Puntero = 2
  42.                End If
  43.            Next b
  44.            If a <> nLineas Then
  45.                Puntero = Puntero
  46.                Mid(OutDataTemp, Puntero, 2) = vbCrLf
  47.                Puntero = Puntero + 2
  48.            End If
  49.            Caption = a
  50.        Next a
  51. 1:      Erase CelVar
  52.    End If
  53.    OutData = OutData & Trim$(OutDataTemp)
  54. End Sub
  55. Private Sub Form_Load()
  56.    Text2.Alignment = 2 '   //  Modo centralizado
  57. End Sub
  58. Private Sub Command1_Click()
  59. Dim datas                   As String
  60.    Call GenerateTrianglePascal(Val(Text1.Text), datas)
  61.    Text2.Text = datas
  62. End Sub
  63.  
  64.  

la longitud de los números esta limitada por el buffer que solo le asigne 255 caracteres.

El limite de lineas es de 932 si es que no se aumentan los buffers de memoria



P.D.: El código en lugar de hacerle un redim a celvar(x,x) puede hacerse de esta forma Celver(1,x) pero decidí dejar los registros anteriores por si alguien deseaba hacerles cambios aun que de esta forma en la que lo deje gasta mas memoria ram en el modo celvar(1,x) no gastaría tanta pero tendría que estarse usando copymemori (API) para mover el de 1 a 0 y sacar los nuevos valores.



Dulces Lunas!¡
103  Programación / Programación Visual Basic / Feliz Navidad en: 25 Diciembre 2009, 11:40 am

Solo eso Desearles una feliz Navidad  :rolleyes: :rolleyes: :rolleyes: :rolleyes:

P.D.: ya me voy a dormir estoy hasta las chanclas jajaja.
104  Programación / Programación Visual Basic / [Source] Kryptonite Spreader Version InfrAngeluX en: 15 Diciembre 2009, 21:11 pm

Este es el Codigo Fuente del Programa Espuesto en este Post:

http://foro.elhacker.net/analisis_y_diseno_de_malware/kryptonite_spreader_version_infrangelux-t277681.0.html


Al DESCARGAR EL PROGRAMA, LOS USUARIOS SE HACEN RESPONSABLES DE SUS USOS DADOS POR EL MISMO EXCLUYENDOME DE SUS ACCIONES

  < Descargar > Solo AVG lo detecta ( EL STUB A SIDO RECONSTRUIDO AL 100% DEL ORIGINAL )

  < Descargar >  Versión Original + Source      ( Spreder del cual se origino aun que fue REPROGRAMADO )

Dulces Lunas!¡.
105  Programación / Scripting / * [ 1.1.10 ] Scripting Motor de InfraExplorer en: 9 Diciembre 2009, 09:33 am
Bueno paso solo a dejarles un Programa que desarrolle en Visual Basic 6 que es?

Lo que hace es que ejecuta VBScript pero ademas de eso permite crear una ventana o formulario el cual es Creado fácilmente por Codigo

Donde se empieza el Script?

Todo empieza desde el archivo llamado Main.txt donde se pueden crear Funciones, Procesos, etc.

el programa al descargarlo Muestra un sencillo Formulario con lo que es un textBox en modo Multilinea, el programa comprende solo de 2 Tipos de TextBox singleLine y Multiline

Sus referencias a estos solo por la S y M ( SingleLine, MultiLine ).

Se pueden cargar Multitudes de controles (Actualmente Me falta Añadir un ProgressBar )

CommandButton
textBox
Timer's
CheckBox
OptionalButton
VerticalScroll
HorizontalScroll
Pictures
Images
ListBox
ComboBox
DirListBox
FileListBox
DriveListBox

El Nombre de los controles es igual a el de los archivos Include (Sin el .txt) con excepción del Formulario el cual es llamado cForm

Para Cargar otro control

Código
  1.  
  2. index = cform.cargar ( cform.CONTROL )
  3.  
  4.  

La función Cargar devuelve el Index o Identificador del Control NUEVO

Si falla la carga del control se regresa un valor -1 de lo contrario un valor superior a 0 el cual responde al Index

Para descargar un Control:

Código
  1.  
  2. call cform.Descargar ( cform.CONTROL, index )
  3.  
  4.  

 * Esta funcion Devuelve un valor de 1 si todo fue Bien de lo contrario devuelve -1

 * En si el programa Maneja los controles Básicos de lo que es el Lenguaje Visual Basic 6 ( Donde se ha Desarrollado por COMPLETO )
 * Cada Control conlleva Eventos y por ende sus Propiedades
 * Esta Diseñado para funcionar mediante procesos funciones entre si ( Fue Diseñado para mi InfraExplrerWithComponents )







Dulces Lunas!¡.
106  Programación / Programación Visual Basic / * [ Source ] Encoder and Decode [Algoritmo Simple] en: 6 Diciembre 2009, 08:30 am
No tenia nada que hacer y ademas al fijarme en el post donde publica Sharki su proyecto Personal Algorith el cual solo crea un entador por caracteres estaticos desidi crear un Encoder and decoder o mejor conosidos como

Encryptador con su respectivo desencrypotador

Solo que este SI FUNCIONA POR CONTRASEÑA para Encryptar/Desencryptar los datos (Solo es usada para encryptar/desencryptar de Hecho asi que no seria realmente una Contraseña xP).

Es un codigo Sencillo!¡.

Código
  1.  
  2. ''   /////////////////////////////////////////////////////////////
  3. '   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
  4. '   //                                                         //
  5. '   // Web:     http://InfrAngeluX.Sytes.Net/                  //
  6. '   //                                                         //
  7. '   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
  8. '   // no se eliminen los creditos originales de este codigo   //
  9. '   // No importando que sea modificado/editado o engrandesido //
  10. '   // o achicado, si es en base a este codigo                 //
  11. '   /////////////////////////////////////////////////////////////
  12.  
  13. Option Explicit
  14. Enum tAcciones
  15.    Encryptar = 0
  16.    Desencryptar
  17. End Enum
  18. Public Sub DecodeEncodeString(ByRef Data As String, Pass As String, Optional Accion As tAcciones = Encryptar)
  19. Dim PosPass             As Long
  20. Dim CharData            As String * 1
  21. Dim i                   As Long
  22.    If Pass <> "" Then
  23.        For i = 1 To Len(Data)
  24.            CharData = Mid(Data, i, 1)
  25.            PosPass = IIf((PosPass + 1) > Len(Pass), 1, PosPass + 1)
  26.            Mid(Data, i, 1) = DecodeEncodeChar(CharData, Pass, PosPass, Accion) '    //  Es para evitar usar CopyMemory
  27.        Next i
  28.    End If
  29. End Sub
  30. Public Function DecodeEncodeChar(StrChar As String, ByRef Psss As String, PosPass As Long, Optional Encode_Code As tAcciones = Encryptar) As String
  31. Dim CharPass            As String
  32. Dim NewChar             As Byte
  33. Dim i                   As Long
  34. Const cBytes            As Byte = 255
  35.    CharPass = Mid(Psss, PosPass, 1)
  36.    '   //  Buscamos la coherencia
  37.    For i = 0 To cBytes
  38.        If StrChar = Chr(i) Then
  39.            '   //  Calculamos el Nuevo Caracter
  40.            If Encode_Code = Encryptar Then
  41.                NewChar = IIf(Asc(CharPass) + Asc(StrChar) > cBytes, _
  42.                             (Asc(CharPass) + Asc(StrChar)) - cBytes, _
  43.                              Asc(CharPass) + Asc(StrChar))
  44.            Else
  45.                NewChar = IIf(Asc(StrChar) - Asc(CharPass) < 0, _
  46.                              cBytes + (Asc(StrChar) - Asc(CharPass)), _
  47.                              Asc(StrChar) - Asc(CharPass))
  48.            End If
  49.            DecodeEncodeChar = Chr(NewChar)
  50.            Exit For
  51.        End If
  52.    Next i
  53. End Function
  54.  
  55.  

ejemplo de uso:

Agregar en un formuario
1 TextBox
2 CommandButton con matrix 0 y 1 respectivamente

Código
  1.  
  2. Private Sub Command1_Click(Index As Integer)
  3.    Dim AuxData         As String
  4.    AuxData = Text1.Text
  5.    Call DecodeEncodeString(AuxData, "Miguel Angel Ortega Avila", IIf(Index = 0, Encryptar, Desencryptar))
  6.    Text1.Text = AuxData
  7. End Sub
  8.  
  9.  

editpo: Junto Post --->

Para quienes no les sirva bien aquí tienen el codigo implementado en un formulario:

http://infrangelux.sytes.net/Descargas/Crypters/Encode And Decode.rar

Nota: Los caracteres Nulos / Null / Chr(0) No son imprimibles en los Textbox o similares Ojo con eso.

Dulces Lunas!¡.
107  Programación / Programación Visual Basic / programacion paralela en: 5 Diciembre 2009, 01:20 am

Alguien sabe sobre el tema? o una liga a algun lenguaje open source que aplique la utilizacion de los dos nucleo?

Dulces Lunas!¡.
108  Programación / Programación Visual Basic / * [ Source ] CLSFrameLimiter.cls (Frecuencia) en: 3 Diciembre 2009, 17:21 pm
Este codigo es especialmente para los juegos o lo que este dentro de un Do/While o similar (Juegos, o Cantroles DIbUJAdOS, o sencillamente procesos en un Do/While por decir alguno).


En un Modulo Tipo Clase:

CLSFrameLimiter.cls

Código
  1.  
  2. ''   /////////////////////////////////////////////////////////////
  3. '   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
  4. '   //                                                         //
  5. '   // Web:     http://InfrAngeluX.Sytes.Net/                  //
  6. '   //                                                         //
  7. '   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
  8. '   // no se eliminen los creditos originales de este codigo   //
  9. '   // No importando que sea modificado/editado o engrandesido //
  10. '   // o achicado, si es en base a este codigo                 //
  11. '   /////////////////////////////////////////////////////////////
  12.  
  13. Option Explicit
  14.  
  15. Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
  16. Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
  17.  
  18. Private m_CurFrequency As Currency
  19. Private m_HasCounter As Boolean
  20. Private m_FrameStart As Currency
  21. Private m_FrameEnd As Currency
  22. Private m_CurTime As Currency
  23. Private m_Delay As Currency
  24. Private m_LastSecond As Long
  25. Private m_LastSecondCount As Long
  26. Private m_FrameCount As Long
  27.  
  28. Private Sub Class_Initialize()
  29.    m_HasCounter = QueryPerformanceFrequency(m_CurFrequency)
  30.    m_CurFrequency = m_CurFrequency * 10000
  31. End Sub
  32.  
  33. Public Function GetFPS() As Long
  34.    GetFPS = m_LastSecondCount
  35. End Function
  36.  
  37. Public Sub LimitFrames(ByVal nFPS As Integer)
  38.    If Second(Now) <> m_LastSecond Then
  39.        m_LastSecond = Second(Now)
  40.        m_LastSecondCount = m_FrameCount
  41.        m_FrameCount = 0
  42.    End If
  43.    m_FrameCount = m_FrameCount + 1
  44.    QueryPerformanceCounter m_FrameEnd
  45.    '   //  m_Delay = ((1000 / nFPS) * m_CurFrequency / 10000000) - (m_FrameEnd - m_FrameStart)
  46.    m_Delay = ((1 / nFPS) * m_CurFrequency / 10000) - (m_FrameEnd - m_FrameStart)
  47.    Do
  48.        DoEvents
  49.        QueryPerformanceCounter m_CurTime
  50.    Loop Until (m_CurTime - m_FrameEnd) >= m_Delay
  51.  
  52.    QueryPerformanceCounter m_FrameStart
  53. End Sub
  54.  

Forma de USO

Código
  1.  
  2. Dim FrameLimit                      As New CLSFrameLimiter
  3. Dim NoSalir                         as boolean
  4.  
  5. Private Sub Form_Click()
  6.    NoSalir=not NoSalir
  7. End Sub
  8.  
  9. Private Sub Form_Load()
  10.    NoSalir = false
  11.    show
  12.    While NoSalir
  13.        '   //  No es nesesario DoEvents, Sleep() o waitMessage() {En algun caso es usado NO?}
  14.        Call FrameLimit.LimitFrames(40)
  15.        caption = FrameLimit.GetFPS
  16.    Wend
  17. End Sub
  18.  
  19.  



Ejemplo Demostrativo:

Código
  1. Option Explicit
  2.  
  3. 'Used to just grab framerates.
  4. Private Declare Function GetTickCount Lib "kernel32" () As Long
  5. Dim NoSalir                         As Boolean
  6. Dim FrameLimit                      As New CLSFrameLimiter
  7.  
  8. Private Sub Form_Click()
  9.    NoSalir = Not NoSalir
  10.    Call PruebaFrameSecunds
  11. End Sub
  12.  
  13. Private Sub PruebaFrameSecunds()
  14. Dim lngCount                        As Long
  15. Dim lngFPS                          As Long
  16. Dim lngTick                         As Long
  17. Dim okFPS                           As Long
  18.    While NoSalir
  19.        '   //  No es nesesario DoEvents, Sleep() o waitMessage() {En algun caso es usado NO?}
  20.        Call FrameLimit.LimitFrames(40)
  21.        Cls
  22.        lngFPS = lngFPS + 1
  23.        If lngTick < GetBetterTick Then
  24.            okFPS = lngFPS
  25.            lngTick = GetBetterTick + 1000
  26.            lngFPS = 0
  27.        End If
  28.        Print "Frames por calculo: " & CStr(okFPS)
  29.        Print "Frames por la Funcion: " & FrameLimit.GetFPS
  30.    Wend
  31. End Sub
  32.  
  33. Private Function GetBetterTick() As Long
  34.    Static LastTime As Long
  35.    If LastTime >= 0 And GetTickCount < 0 Then LastTime = GetTickCount
  36.    If LastTime <= 0 And GetTickCount > 0 Then LastTime = GetTickCount
  37.    GetBetterTick = GetTickCount - LastTime
  38. End Function
  39.  
  40. Private Sub Form_Load()
  41.    AutoRedraw = True
  42. End Sub
  43.  

Dulces Lunas!¡.
109  Foros Generales / Sugerencias y dudas sobre el Foro / Error Link Crash Navegador un post movido por Novlucker en: 20 Noviembre 2009, 03:31 am
que rollo que onda con tu enlace en VB6

http://foro.elhacker.net/programacion_vb/movido_error_simpatico-t275114.0.html

Lo abro y me cierra la ventana del explorador... mmm ¬¬#, tengo que ver el fuente xD
110  Programación / Programación Visual Basic / [Source] Ordenar Array (Low y Fast) en: 28 Octubre 2009, 23:31 pm
Versión Lenta... Fue sacado del ListBoxEx de LeandroAscierto, con una modificación para pasar el array en la funcion.

Código
  1. Option Explicit
  2.  
  3. Public Enum EnuListOrder
  4.    AcendetOrder = 0
  5.    DecendentOrder = 1
  6. End Enum
  7.  
  8. Public Sub Sorted(ByRef Item(), Optional Order As EnuListOrder = DecendentOrder)
  9.    Dim Itm As String
  10.    Dim J As Double
  11.    Dim i As Double
  12.    Dim mcount As Long
  13.    mcount = UBound(Item)
  14.  
  15.    If Order = AcendetOrder Then
  16.        For J = 0 To mcount
  17.            For i = 0 To mcount
  18.                If Item(i) > Item(i + 1) Then
  19.                    Itm = Item(i + 1)
  20.                    Item(i + 1) = Item(i)
  21.                    Item(i) = Itm
  22.                End If
  23.            Next i
  24.        Next J
  25.    Else
  26.        For J = 0 To mcount - 2
  27.            For i = 0 To mcount - 2
  28.                If Item(i) < Item(i + 1) Then
  29.                    Itm = Item(i + 1)
  30.                    Item(i + 1) = Item(i)
  31.                    Item(i) = Itm
  32.                End If
  33.            Next i
  34.        Next J
  35.    End If
  36. End Sub
  37.  


El siguiente es una versión mejorada por un Servidor... ordena adecuadamente los numeros ( Antes 0, 1, 10, 100,1000, ahora 0,1,2,3,4,5 ), Es muchas veces mas rapido que el anterior y más largo el codigo...

Código
  1. '
  2. '   /////////////////////////////////////////////////////////////
  3. '   // Autor Algoritmo: C.A.R. Hoare en 1960                   //
  4. '   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
  5. '   //                                                         //
  6. '   // Web:     http://InfrAngeluX.Sytes.Net/                  //
  7. '   //                                                         //
  8. '   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
  9. '   // no se eliminen los creditos originales de este codigo   //
  10. '   // No importando que sea modificado/editado o engrandesido //
  11. '   // o achicado, si es en base a este codigo                 //
  12. '   /////////////////////////////////////////////////////////////
  13.  
  14. Option Explicit
  15. Enum EnuListOrder
  16.    AcendetOrder = 0
  17.    DecendentOrder
  18. End Enum
  19. Private Sub AuxOrden(ByRef mArray(), _
  20.                    i As Long, j As Long, _
  21.                    il As Long, jl As Long)
  22. Dim c                                       As String
  23. Dim c2                                      As Long
  24.    c = mArray(j)
  25.    mArray(j) = mArray(i)
  26.    mArray(i) = c
  27.    c2 = il
  28.    il = -jl
  29.    jl = -c2
  30. End Sub
  31. Private Sub PreSort(ByRef mArray(), lb As Long, ub As Long, _
  32.                    k As Long, _
  33.            Optional Order As EnuListOrder = DecendentOrder)
  34. Dim i                                       As Long
  35. Dim j                                       As Long
  36. Dim il                                      As Long
  37. Dim jl                                      As Long
  38.    il = 0: jl = -1
  39.    i = lb: j = ub
  40.    While i < j
  41.        If Order = DecendentOrder Then
  42.            If IsNumeric(mArray(i)) And IsNumeric(mArray(j)) Then
  43.                If Val(mArray(i)) > Val(mArray(j)) Then
  44.                    Call AuxOrden(mArray(), i, j, il, jl)
  45.                End If
  46.            Else
  47.                If mArray(i) > mArray(j) Then
  48.                    Call AuxOrden(mArray(), i, j, il, jl)
  49.                End If
  50.            End If
  51.        Else
  52.            If IsNumeric(mArray(i)) And IsNumeric(mArray(j)) Then
  53.                If Val(mArray(i)) < Val(mArray(j)) Then
  54.                    Call AuxOrden(mArray(), i, j, il, jl)
  55.                End If
  56.            Else
  57.                If mArray(i) < mArray(j) Then
  58.                    Call AuxOrden(mArray(), i, j, il, jl)
  59.                End If
  60.            End If
  61.        End If
  62.        i = i + il
  63.        j = j + jl
  64.    Wend
  65.    k = i
  66. End Sub
  67. Private Sub QSort(ByRef mArray(), lb As Long, ub As Long, _
  68.                Optional Order As EnuListOrder = DecendentOrder)
  69. Dim k                                   As Long
  70.    If lb < ub Then
  71.        PreSort mArray, lb, ub, k, Order
  72.        Call QSort(mArray, lb, k - 1, Order)
  73.        Call QSort(mArray, k + 1, ub, Order)
  74.    End If
  75. End Sub
  76. Public Sub Start_QuickSort(ByRef mArray(), _
  77.                Optional Order As EnuListOrder = DecendentOrder)
  78.    If (Not (mArray)) = -1 Then Exit Sub ' Es para ver si esta inicializado el Arreglo
  79.    QSort mArray, LBound(mArray), UBound(mArray), DecendentOrder
  80. End Sub
  81.  

Ejemplo de Uso o llamda:

Código
  1. Option Explicit
  2. Private Sub Form_Load()
  3.      Dim i As Integer
  4.      Dim mArray(200)
  5.      For i = 0 To 100
  6.          Randomize
  7.          mArray(i) = i
  8.      Next i
  9.      For i = 101 To 200
  10.          Randomize
  11.          mArray(i) = Chr(Round(64 * Rnd()) + 65)
  12.      Next i
  13.      Start_QuickSort mArray, DecendentOrder
  14.      For i = 0 To 200
  15.          Debug.Print mArray(i)
  16.      Next i
  17. End Sub
  18.  

Dulces Lunas!¡.
Páginas: 1 2 3 4 5 6 7 8 9 10 [11] 12 13 14
WAP2 - Aviso Legal - Powered by SMF 1.1.21 | SMF © 2006-2008, Simple Machines