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.

 
'
' ////////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel )            //
' //                                                            //
' // Web: http://InfrAngeluX.Sytes.Net/                         //
' //                                                            //
' // |-> Pueden Distribuir Este Código siempre y cuando         //
' // no se eliminen los créditos originales de este código      //
' // No importando que sea modificado/editado o engrandecido    //
' // o achicado, si es en base a este código                    //
' ////////////////////////////////////////////////////////////////
 
Option Explicit
Enum ActionsHexStr
    HexToString = 0
    StringToHex
End Enum
Public Function HexAndString(ByVal vData As String, Optional Accion As ActionsHexStr = HexToString) As String
Dim LenBuffer               As Long
Dim LenOfBuffer             As Integer
Dim Puntero                 As Long
Dim I                       As Long
Dim vStep                   As Integer
    If CBool(IIf(Accion = HexToString And (Len(vData) Mod 2) = 0, True, IIf(Accion = StringToHex, True, False))) Then
        LenBuffer = IIf(Accion = HexToString, Len(vData) / 2, Len(vData) * 2)
        LenOfBuffer = IIf(Accion = HexToString, 1, 2)
        HexAndString = Space(LenBuffer)
        vStep = IIf(Accion = HexToString, 2, 1)
        Puntero = 1
        For I = 1 To Len(vData) Step vStep
            If Accion = HexToString Then
                Mid(HexAndString, Puntero, LenOfBuffer) = Chr$(Val("&H" & Mid$(vData, I, 2)))
                Puntero = Puntero + 1
            Else
                Mid(HexAndString, Puntero, LenOfBuffer) = Hex$(Asc(Mid$(vData, I, 1)))
                Puntero = Puntero + 2
            End If
        Next I
    End If
End Function
 
 

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

Dulces Lunas!¡

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

 
'
' ////////////////////////////////////////////////////////////////
' // 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
 
Public Function GenerateTrianglePascal(ByVal nLineas As Long) As String
On Error GoTo 1
Dim a                       As Long
Dim b                       As Long
Dim CelVar()                As Double
    If nLineas > 0 Then
        ReDim CelVar(nLineas, nLineas)
        For a = 1 To nLineas
            For b = 1 To a: DoEvents
                CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
                GenerateTrianglePascal = GenerateTrianglePascal & CelVar(a, b) & IIf(Not b = a, String(3, " "), "")
            Next b
            If a <> nLineas Then GenerateTrianglePascal = GenerateTrianglePascal & vbCrLf
        Next a
1:      Erase CelVar
    End If
End Function
 
Private Sub Form_Load()
    Text2.Alignment = 2 '   //  Modo centralizado
End Sub
 
Private Sub Command1_Click()
    Text2.Text = GenerateTrianglePascal(Val(Text1.Text))
End Sub
 
 

con dowhile y doevents

 
'
' ////////////////////////////////////////////////////////////////
' // 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
 
Public Function GenerateTrianglePascal(ByVal nLineas As Long) As String
On Error GoTo 1
Dim a                           As Long
Dim b                           As Long
Dim CelVar()                    As Double
    If nLineas > 0 Then
        ReDim CelVar(nLineas, nLineas)
        a = 1: Do While a <= nLineas
            b = 1: Do While b <= a: DoEvents
                CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
                GenerateTrianglePascal = GenerateTrianglePascal & CelVar(a, b) & IIf(Not b = a, String(2, " "), "")
            b = b + 1: Loop
            If a <> nLineas Then GenerateTrianglePascal = GenerateTrianglePascal & vbCrLf
        a = a + 1: Loop
1:      Erase CelVar
    End If
End Function
 
Private Sub Form_Load()
    Text2.Alignment = 2 '   //  Modo centralizado
End Sub
 
Private Sub Command1_Click()
    Text2.Text = GenerateTrianglePascal(Val(Text1.Text))
End Sub
 
 

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

 
'
' ////////////////////////////////////////////////////////////////
' // 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
 
Public Sub GenerateTrianglePascal(ByVal nLineas As Long, ByRef OutData As String)
'On Error GoTo 1
Dim a                       As Long
Dim b                       As Long
Dim Puntero                 As Long
Dim Longitud                As Long
Dim Temporal                As String
Dim CelVar()                As Double
Dim OutDataTemp             As String
Const KiloByte              As Long = 5120
    If nLineas > 0 Then
        ReDim CelVar(nLineas, nLineas)
        Puntero = 1
        OutDataTemp = Space(KiloByte)
        Temporal = Space(255)
        For a = 1 To nLineas
            For b = 1 To a: DoEvents
                CelVar(a, b) = Val(IIf(b = 1, 1, Val(CelVar(a - 1, b - 1)) + Val(CelVar(a - 1, b))))
                Temporal = CelVar(a, b) & IIf(a <> b, " ", "")
                Longitud = Len(Temporal)
                Mid(OutDataTemp, Puntero, Longitud) = Temporal
                Puntero = Puntero + Longitud
                If Puntero > KiloByte Then
                    OutData = OutData & OutDataTemp
                    OutDataTemp = Space(KiloByte)
                    Puntero = 2
                End If
            Next b
            If a <> nLineas Then
                Puntero = Puntero
                Mid(OutDataTemp, Puntero, 2) = vbCrLf
                Puntero = Puntero + 2
            End If
            Caption = a
        Next a
1:      Erase CelVar
    End If
    OutData = OutData & Trim$(OutDataTemp)
End Sub
Private Sub Form_Load()
    Text2.Alignment = 2 '   //  Modo centralizado
End Sub
Private Sub Command1_Click()
Dim datas                   As String
    Call GenerateTrianglePascal(Val(Text1.Text), datas)
    Text2.Text = datas
End Sub
 
 

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!¡

Solo eso Desearles una feliz Navidad 

P.D.: ya me voy a dormir estoy hasta las chanclas jajaja.

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!¡.

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

 
index = cform.cargar ( cform.CONTROL ) 
 
 

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:

 
call cform.Descargar ( cform.CONTROL, index )
 
 

 * 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!¡.

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!¡.

 
''   /////////////////////////////////////////////////////////////
'   // 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
Enum tAcciones
    Encryptar = 0
    Desencryptar
End Enum
Public Sub DecodeEncodeString(ByRef Data As String, Pass As String, Optional Accion As tAcciones = Encryptar)
Dim PosPass             As Long
Dim CharData            As String * 1
Dim i                   As Long
    If Pass <> "" Then
        For i = 1 To Len(Data)
            CharData = Mid(Data, i, 1)
            PosPass = IIf((PosPass + 1) > Len(Pass), 1, PosPass + 1)
            Mid(Data, i, 1) = DecodeEncodeChar(CharData, Pass, PosPass, Accion) '    //  Es para evitar usar CopyMemory
        Next i
    End If
End Sub
Public Function DecodeEncodeChar(StrChar As String, ByRef Psss As String, PosPass As Long, Optional Encode_Code As tAcciones = Encryptar) As String
Dim CharPass            As String
Dim NewChar             As Byte
Dim i                   As Long
Const cBytes            As Byte = 255
    CharPass = Mid(Psss, PosPass, 1)
    '   //  Buscamos la coherencia
    For i = 0 To cBytes
        If StrChar = Chr(i) Then
            '   //  Calculamos el Nuevo Caracter
            If Encode_Code = Encryptar Then
                NewChar = IIf(Asc(CharPass) + Asc(StrChar) > cBytes, _
                             (Asc(CharPass) + Asc(StrChar)) - cBytes, _
                              Asc(CharPass) + Asc(StrChar))
            Else
                NewChar = IIf(Asc(StrChar) - Asc(CharPass) < 0, _
                              cBytes + (Asc(StrChar) - Asc(CharPass)), _
                              Asc(StrChar) - Asc(CharPass))
            End If
            DecodeEncodeChar = Chr(NewChar)
            Exit For
        End If
    Next i
End Function
 
 

ejemplo de uso:

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

 
Private Sub Command1_Click(Index As Integer)
    Dim AuxData         As String
    AuxData = Text1.Text
    Call DecodeEncodeString(AuxData, "Miguel Angel Ortega Avila", IIf(Index = 0, Encryptar, Desencryptar))
    Text1.Text = AuxData
End Sub
 
 

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


Dulces Lunas!¡.

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

Dulces Lunas!¡.

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

 
''   /////////////////////////////////////////////////////////////
'   // 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 Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
 
Private m_CurFrequency As Currency
Private m_HasCounter As Boolean
Private m_FrameStart As Currency
Private m_FrameEnd As Currency
Private m_CurTime As Currency
Private m_Delay As Currency
Private m_LastSecond As Long
Private m_LastSecondCount As Long
Private m_FrameCount As Long
 
Private Sub Class_Initialize()
    m_HasCounter = QueryPerformanceFrequency(m_CurFrequency)
    m_CurFrequency = m_CurFrequency * 10000
End Sub
 
Public Function GetFPS() As Long
    GetFPS = m_LastSecondCount
End Function
 
Public Sub LimitFrames(ByVal nFPS As Integer)
    If Second(Now) <> m_LastSecond Then
        m_LastSecond = Second(Now)
        m_LastSecondCount = m_FrameCount
        m_FrameCount = 0
    End If
    m_FrameCount = m_FrameCount + 1
    QueryPerformanceCounter m_FrameEnd
    '   //  m_Delay = ((1000 / nFPS) * m_CurFrequency / 10000000) - (m_FrameEnd - m_FrameStart)
    m_Delay = ((1 / nFPS) * m_CurFrequency / 10000) - (m_FrameEnd - m_FrameStart)
    Do
        DoEvents
        QueryPerformanceCounter m_CurTime
    Loop Until (m_CurTime - m_FrameEnd) >= m_Delay
 
    QueryPerformanceCounter m_FrameStart
End Sub
 

Forma de USO

 
Dim FrameLimit                      As New CLSFrameLimiter
Dim NoSalir                         as boolean
 
Private Sub Form_Click()
    NoSalir=not NoSalir
End Sub
 
Private Sub Form_Load()
    NoSalir = false
    show
    While NoSalir
        '   //  No es nesesario DoEvents, Sleep() o waitMessage() {En algun caso es usado NO?}
        Call FrameLimit.LimitFrames(40)
        caption = FrameLimit.GetFPS
    Wend
End Sub
 
 

Ejemplo Demostrativo:

Option Explicit
 
'Used to just grab framerates.
Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim NoSalir                         As Boolean
Dim FrameLimit                      As New CLSFrameLimiter
 
Private Sub Form_Click()
    NoSalir = Not NoSalir
    Call PruebaFrameSecunds
End Sub
 
Private Sub PruebaFrameSecunds()
Dim lngCount                        As Long
Dim lngFPS                          As Long
Dim lngTick                         As Long
Dim okFPS                           As Long
    While NoSalir
        '   //  No es nesesario DoEvents, Sleep() o waitMessage() {En algun caso es usado NO?}
        Call FrameLimit.LimitFrames(40)
        Cls
        lngFPS = lngFPS + 1
        If lngTick < GetBetterTick Then
            okFPS = lngFPS
            lngTick = GetBetterTick + 1000
            lngFPS = 0
        End If
        Print "Frames por calculo: " & CStr(okFPS)
        Print "Frames por la Funcion: " & FrameLimit.GetFPS
    Wend
End Sub
 
Private Function GetBetterTick() As Long
    Static LastTime As Long
    If LastTime >= 0 And GetTickCount < 0 Then LastTime = GetTickCount
    If LastTime <= 0 And GetTickCount > 0 Then LastTime = GetTickCount
    GetBetterTick = GetTickCount - LastTime
End Function
 
Private Sub Form_Load()
    AutoRedraw = True
End Sub
 

Dulces Lunas!¡.

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

---

Versión Lenta... Fue sacado del ListBoxEx de LeandroAscierto, con una modificación para pasar el array en la funcion.

Option Explicit
 
Public Enum EnuListOrder
    AcendetOrder = 0
    DecendentOrder = 1
End Enum
 
Public Sub Sorted(ByRef Item(), Optional Order As EnuListOrder = DecendentOrder)
    Dim Itm As String
    Dim J As Double
    Dim i As Double
    Dim mcount As Long
    mcount = UBound(Item)
 
    If Order = AcendetOrder Then
        For J = 0 To mcount
            For i = 0 To mcount
                If Item(i) > Item(i + 1) Then
                    Itm = Item(i + 1)
                    Item(i + 1) = Item(i)
                    Item(i) = Itm
                End If
            Next i
        Next J
    Else
        For J = 0 To mcount - 2
            For i = 0 To mcount - 2
                If Item(i) < Item(i + 1) Then
                    Itm = Item(i + 1)
                    Item(i + 1) = Item(i)
                    Item(i) = Itm
                End If
            Next i
        Next J
    End If
End Sub
 

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...

'
'   /////////////////////////////////////////////////////////////
'   // 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                 //
'   /////////////////////////////////////////////////////////////
 
Option Explicit
Enum EnuListOrder
    AcendetOrder = 0
    DecendentOrder
End Enum
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)
    If (Not (mArray)) = -1 Then Exit Sub ' Es para ver si esta inicializado el Arreglo
    QSort mArray, LBound(mArray), UBound(mArray), DecendentOrder
End Sub
 

Ejemplo de Uso o llamda:

Option Explicit
Private Sub Form_Load()
      Dim i As Integer
      Dim mArray(200)
      For i = 0 To 100
          Randomize
          mArray(i) = i
      Next i
      For i = 101 To 200
          Randomize
          mArray(i) = Chr(Round(64 * Rnd()) + 65)
      Next i
      Start_QuickSort mArray, DecendentOrder
      For i = 0 To 200
          Debug.Print mArray(i)
      Next i
End Sub
 

Dulces Lunas!¡.