Mensajes

Vamos por partes.

Esto que quieres hacer exije conocimientos de Electrónica,  y Programación VB.

Espero que tu interfaz este bien diseñada y montada, podrias dañar la placa base.

En cuanto a la programacion:

La solución esta en este link

http://www.todorobot.com.ar/proyectos/paralelo/paralelo.htm

Adaptalo a tus necesidades. No es dificil

Salu2

Posdata: Esta todo muy claro y podias haberte molestado un poquito en buscar 1 code para el puerto parelelo. Para algo esta google.

Este tema para mi esta Zanjado

Puede que el juego tenga sus propios Aceleradores y no lo acepte bien.

Propongo localizar la ventana y enviarle el parámetro LPARAM

WM_MBUTTONDBLCLK

O

WM_LBUTTONUP



Asi funcionará seguro

Salu2

Propiedades Importantes del control ProgressBar:

Min : valor mínimo de la barra

Max : valor máximo que alcanzara

Value : Valor actual


El truco para que este control funcione es el siguiente:

Asignar el valor Min y Max desde el código y en tiempo de
ejecución.

Asignar el valor de la propiedad Value desde el código y en tiempo de ejecución con un valor tipo Long

Salu2

Hola a todos.

Verán, estoy desarrollado un BIOS-UPDATE. Es decir, un programa que actualiza tu BIOS desde Windows.

Se le indica el fichero de actualización y ya está.

El problema es el siguiente:

Al intentar escribir el fichero en la BIOS, el programa me da error y se cierra.

Supongo que será porque esa dirección esta reservada o restringida por windows.

¿Qué puedo hacer para que me deje escribirlo ?

Ajustar los permisos a administrador ?

Podré desbloquearla con VirtualProtecEx o VirtualUnlock ?

Gracias

Que llame a un boton de donde ? Del formulario ?

Explicate mejor.

Mira esto:

http://www.modelo.edu.mx/univ/virtech/circuito/dllvb.htm

y en especial este:

http://www.anser.com.ar/pc.htm

Salu2

Existen controles OCX que hacen esto de forma muy facil y comoda, aunque si no quieres tener esa dependencia, usa la Api.

Busca 1 poco por internet o intenta hacerlo tu mismo.

Salu2

Como creo que la Seguridad es IMPORTANTE...

Aunque en realidad no existe  xDDD

No se quejaran, eh ?

Código [Seleccionar] Expandir


Option Explicit

' Base64 Encoding/Decoding Algorithm
'
' This algorithms encodes and decodes data into Base64
' format. This format is extremely more efficient than
' Hexadecimal encoding.

Private m_bytIndex(0 To 63) As Byte
Private m_bytReverseIndex(0 To 255) As Byte
Private Const k_bytEqualSign As Byte = 61
Private Const k_bytMask1 As Byte = 3
Private Const k_bytMask2 As Byte = 15
Private Const k_bytMask3 As Byte = 63
Private Const k_bytMask4 As Byte = 192
Private Const k_bytMask5 As Byte = 240
Private Const k_bytMask6 As Byte = 252
Private Const k_bytShift2 As Byte = 4
Private Const k_bytShift4 As Byte = 16
Private Const k_bytShift6 As Byte = 64
Private Const k_lMaxBytesPerLine As Long = 152
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)

Public Function Decode64(sInput As String) As String
    If sInput = "" Then Exit Function
    Decode64 = StrConv(DecodeArray64(sInput), vbUnicode)
End Function

Public Function DecodeArray64(sInput As String) As Byte()
    Dim bytInput() As Byte
    Dim bytWorkspace() As Byte
    Dim bytResult() As Byte
    Dim lInputCounter As Long
    Dim lWorkspaceCounter As Long

    bytInput = Replace(Replace(sInput, vbCrLf, ""), "=", "")
    ReDim bytWorkspace(LBound(bytInput) To (UBound(bytInput) * 2)) As Byte
    lWorkspaceCounter = LBound(bytWorkspace)
    For lInputCounter = LBound(bytInput) To UBound(bytInput)
        bytInput(lInputCounter) = m_bytReverseIndex(bytInput(lInputCounter))
    Next lInputCounter

    For lInputCounter = LBound(bytInput) To (UBound(bytInput) - ((UBound(bytInput) Mod 8) + 8)) Step 8
        bytWorkspace(lWorkspaceCounter) = (bytInput(lInputCounter) * k_bytShift2) + (bytInput(lInputCounter + 2) \ k_bytShift4)
        bytWorkspace(lWorkspaceCounter + 1) = ((bytInput(lInputCounter + 2) And k_bytMask2) * k_bytShift4) + (bytInput(lInputCounter + 4) \ k_bytShift2)
        bytWorkspace(lWorkspaceCounter + 2) = ((bytInput(lInputCounter + 4) And k_bytMask1) * k_bytShift6) + bytInput(lInputCounter + 6)
        lWorkspaceCounter = lWorkspaceCounter + 3
    Next lInputCounter

    Select Case (UBound(bytInput) Mod 8):
        Case 3:
            bytWorkspace(lWorkspaceCounter) = (bytInput(lInputCounter) * k_bytShift2) + (bytInput(lInputCounter + 2) \ k_bytShift4)
        Case 5:
            bytWorkspace(lWorkspaceCounter) = (bytInput(lInputCounter) * k_bytShift2) + (bytInput(lInputCounter + 2) \ k_bytShift4)
            bytWorkspace(lWorkspaceCounter + 1) = ((bytInput(lInputCounter + 2) And k_bytMask2) * k_bytShift4) + (bytInput(lInputCounter + 4) \ k_bytShift2)
            lWorkspaceCounter = lWorkspaceCounter + 1
        Case 7:
            bytWorkspace(lWorkspaceCounter) = (bytInput(lInputCounter) * k_bytShift2) + (bytInput(lInputCounter + 2) \ k_bytShift4)
            bytWorkspace(lWorkspaceCounter + 1) = ((bytInput(lInputCounter + 2) And k_bytMask2) * k_bytShift4) + (bytInput(lInputCounter + 4) \ k_bytShift2)
            bytWorkspace(lWorkspaceCounter + 2) = ((bytInput(lInputCounter + 4) And k_bytMask1) * k_bytShift6) + bytInput(lInputCounter + 6)
            lWorkspaceCounter = lWorkspaceCounter + 2
    End Select

    ReDim bytResult(LBound(bytWorkspace) To lWorkspaceCounter) As Byte
    If LBound(bytWorkspace) = 0 Then lWorkspaceCounter = lWorkspaceCounter + 1
    CopyMemory VarPtr(bytResult(LBound(bytResult))), VarPtr(bytWorkspace(LBound(bytWorkspace))), lWorkspaceCounter
    DecodeArray64 = bytResult
End Function

Public Function Encode64(ByRef sInput As String) As String
    If sInput = "" Then Exit Function
    Dim bytTemp() As Byte
    bytTemp = StrConv(sInput, vbFromUnicode)
    Encode64 = EncodeArray64(bytTemp)
End Function

Public Function EncodeArray64(ByRef bytInput() As Byte) As String
    On Error GoTo ErrorHandler

    Dim bytWorkspace() As Byte, bytResult() As Byte
    Dim bytCrLf(0 To 3) As Byte, lCounter As Long
    Dim lWorkspaceCounter As Long, lLineCounter As Long
    Dim lCompleteLines As Long, lBytesRemaining As Long
    Dim lpWorkSpace As Long, lpResult As Long
    Dim lpCrLf As Long

    If UBound(bytInput) < 1024 Then
        ReDim bytWorkspace(LBound(bytInput) To (LBound(bytInput) + 4096)) As Byte
    Else
        ReDim bytWorkspace(LBound(bytInput) To (UBound(bytInput) * 4)) As Byte
    End If

    lWorkspaceCounter = LBound(bytWorkspace)

    For lCounter = LBound(bytInput) To (UBound(bytInput) - ((UBound(bytInput) Mod 3) + 3)) Step 3
        bytWorkspace(lWorkspaceCounter) = m_bytIndex((bytInput(lCounter) \ k_bytShift2))
        bytWorkspace(lWorkspaceCounter + 2) = m_bytIndex(((bytInput(lCounter) And k_bytMask1) * k_bytShift4) + ((bytInput(lCounter + 1)) \ k_bytShift4))
        bytWorkspace(lWorkspaceCounter + 4) = m_bytIndex(((bytInput(lCounter + 1) And k_bytMask2) * k_bytShift2) + (bytInput(lCounter + 2) \ k_bytShift6))
        bytWorkspace(lWorkspaceCounter + 6) = m_bytIndex(bytInput(lCounter + 2) And k_bytMask3)
        lWorkspaceCounter = lWorkspaceCounter + 8
    Next lCounter

    Select Case (UBound(bytInput) Mod 3):
        Case 0:
            bytWorkspace(lWorkspaceCounter) = m_bytIndex((bytInput(lCounter) \ k_bytShift2))
            bytWorkspace(lWorkspaceCounter + 2) = m_bytIndex((bytInput(lCounter) And k_bytMask1) * k_bytShift4)
            bytWorkspace(lWorkspaceCounter + 4) = k_bytEqualSign
            bytWorkspace(lWorkspaceCounter + 6) = k_bytEqualSign
        Case 1:
            bytWorkspace(lWorkspaceCounter) = m_bytIndex((bytInput(lCounter) \ k_bytShift2))
            bytWorkspace(lWorkspaceCounter + 2) = m_bytIndex(((bytInput(lCounter) And k_bytMask1) * k_bytShift4) + ((bytInput(lCounter + 1)) \ k_bytShift4))
            bytWorkspace(lWorkspaceCounter + 4) = m_bytIndex((bytInput(lCounter + 1) And k_bytMask2) * k_bytShift2)
            bytWorkspace(lWorkspaceCounter + 6) = k_bytEqualSign
        Case 2:
            bytWorkspace(lWorkspaceCounter) = m_bytIndex((bytInput(lCounter) \ k_bytShift2))
            bytWorkspace(lWorkspaceCounter + 2) = m_bytIndex(((bytInput(lCounter) And k_bytMask1) * k_bytShift4) + ((bytInput(lCounter + 1)) \ k_bytShift4))
            bytWorkspace(lWorkspaceCounter + 4) = m_bytIndex(((bytInput(lCounter + 1) And k_bytMask2) * k_bytShift2) + ((bytInput(lCounter + 2)) \ k_bytShift6))
            bytWorkspace(lWorkspaceCounter + 6) = m_bytIndex(bytInput(lCounter + 2) And k_bytMask3)
    End Select

    lWorkspaceCounter = lWorkspaceCounter + 8

    If lWorkspaceCounter <= k_lMaxBytesPerLine Then
        EncodeArray64 = Left$(bytWorkspace, InStr(1, bytWorkspace, Chr$(0)) - 1)
    Else
        bytCrLf(0) = 13
        bytCrLf(1) = 0
        bytCrLf(2) = 10
        bytCrLf(3) = 0
        ReDim bytResult(LBound(bytWorkspace) To UBound(bytWorkspace))
        lpWorkSpace = VarPtr(bytWorkspace(LBound(bytWorkspace)))
        lpResult = VarPtr(bytResult(LBound(bytResult)))
        lpCrLf = VarPtr(bytCrLf(LBound(bytCrLf)))
        lCompleteLines = Fix(lWorkspaceCounter / k_lMaxBytesPerLine)

        For lLineCounter = 0 To lCompleteLines
            CopyMemory lpResult, lpWorkSpace, k_lMaxBytesPerLine
            lpWorkSpace = lpWorkSpace + k_lMaxBytesPerLine
            lpResult = lpResult + k_lMaxBytesPerLine
            CopyMemory lpResult, lpCrLf, 4&
            lpResult = lpResult + 4&
        Next lLineCounter

        lBytesRemaining = lWorkspaceCounter - (lCompleteLines * k_lMaxBytesPerLine)
        If lBytesRemaining > 0 Then CopyMemory lpResult, lpWorkSpace, lBytesRemaining
        EncodeArray64 = Left$(bytResult, InStr(1, bytResult, Chr$(0)) - 1)
    End If
    Exit Function

ErrorHandler:
    Erase bytResult
    EncodeArray64 = bytResult
End Function

Private Sub Class_Initialize()
    m_bytIndex(0) = 65 'Asc("A")
    m_bytIndex(1) = 66 'Asc("B")
    m_bytIndex(2) = 67 'Asc("C")
    m_bytIndex(3) = 68 'Asc("D")
    m_bytIndex(4) = 69 'Asc("E")
    m_bytIndex(5) = 70 'Asc("F")
    m_bytIndex(6) = 71 'Asc("G")
    m_bytIndex(7) = 72 'Asc("H")
    m_bytIndex(8) = 73 'Asc("I")
    m_bytIndex(9) = 74 'Asc("J")
    m_bytIndex(10) = 75 'Asc("K")
    m_bytIndex(11) = 76 'Asc("L")
    m_bytIndex(12) = 77 'Asc("M")
    m_bytIndex(13) = 78 'Asc("N")
    m_bytIndex(14) = 79 'Asc("O")
    m_bytIndex(15) = 80 'Asc("P")
    m_bytIndex(16) = 81 'Asc("Q")
    m_bytIndex(17) = 82 'Asc("R")
    m_bytIndex(18) = 83 'Asc("S")
    m_bytIndex(19) = 84 'Asc("T")
    m_bytIndex(20) = 85 'Asc("U")
    m_bytIndex(21) = 86 'Asc("V")
    m_bytIndex(22) = 87 'Asc("W")
    m_bytIndex(23) = 88 'Asc("X")
    m_bytIndex(24) = 89 'Asc("Y")
    m_bytIndex(25) = 90 'Asc("Z")
    m_bytIndex(26) = 97 'Asc("a")
    m_bytIndex(27) = 98 'Asc("b")
    m_bytIndex(28) = 99 'Asc("c")
    m_bytIndex(29) = 100 'Asc("d")
    m_bytIndex(30) = 101 'Asc("e")
    m_bytIndex(31) = 102 'Asc("f")
    m_bytIndex(32) = 103 'Asc("g")
    m_bytIndex(33) = 104 'Asc("h")
    m_bytIndex(34) = 105 'Asc("i")
    m_bytIndex(35) = 106 'Asc("j")
    m_bytIndex(36) = 107 'Asc("k")
    m_bytIndex(37) = 108 'Asc("l")
    m_bytIndex(38) = 109 'Asc("m")
    m_bytIndex(39) = 110 'Asc("n")
    m_bytIndex(40) = 111 'Asc("o")
    m_bytIndex(41) = 112 'Asc("p")
    m_bytIndex(42) = 113 'Asc("q")
    m_bytIndex(43) = 114 'Asc("r")
    m_bytIndex(44) = 115 'Asc("s")
    m_bytIndex(45) = 116 'Asc("t")
    m_bytIndex(46) = 117 'Asc("u")
    m_bytIndex(47) = 118 'Asc("v")
    m_bytIndex(48) = 119 'Asc("w")
    m_bytIndex(49) = 120 'Asc("x")
    m_bytIndex(50) = 121 'Asc("y")
    m_bytIndex(51) = 122 'Asc("z")
    m_bytIndex(52) = 48 'Asc("0")
    m_bytIndex(53) = 49 'Asc("1")
    m_bytIndex(54) = 50 'Asc("2")
    m_bytIndex(55) = 51 'Asc("3")
    m_bytIndex(56) = 52 'Asc("4")
    m_bytIndex(57) = 53 'Asc("5")
    m_bytIndex(58) = 54 'Asc("6")
    m_bytIndex(59) = 55 'Asc("7")
    m_bytIndex(60) = 56 'Asc("8")
    m_bytIndex(61) = 57 'Asc("9")
    m_bytIndex(62) = 43 'Asc("+")
    m_bytIndex(63) = 47 'Asc("/")
    m_bytReverseIndex(65) = 0 'Asc("A")
    m_bytReverseIndex(66) = 1 'Asc("B")
    m_bytReverseIndex(67) = 2 'Asc("C")
    m_bytReverseIndex(68) = 3 'Asc("D")
    m_bytReverseIndex(69) = 4 'Asc("E")
    m_bytReverseIndex(70) = 5 'Asc("F")
    m_bytReverseIndex(71) = 6 'Asc("G")
    m_bytReverseIndex(72) = 7 'Asc("H")
    m_bytReverseIndex(73) = 8 'Asc("I")
    m_bytReverseIndex(74) = 9 'Asc("J")
    m_bytReverseIndex(75) = 10 'Asc("K")
    m_bytReverseIndex(76) = 11 'Asc("L")
    m_bytReverseIndex(77) = 12 'Asc("M")
    m_bytReverseIndex(78) = 13 'Asc("N")
    m_bytReverseIndex(79) = 14 'Asc("O")
    m_bytReverseIndex(80) = 15 'Asc("P")
    m_bytReverseIndex(81) = 16 'Asc("Q")
    m_bytReverseIndex(82) = 17 'Asc("R")
    m_bytReverseIndex(83) = 18 'Asc("S")
    m_bytReverseIndex(84) = 19 'Asc("T")
    m_bytReverseIndex(85) = 20 'Asc("U")
    m_bytReverseIndex(86) = 21 'Asc("V")
    m_bytReverseIndex(87) = 22 'Asc("W")
    m_bytReverseIndex(88) = 23 'Asc("X")
    m_bytReverseIndex(89) = 24 'Asc("Y")
    m_bytReverseIndex(90) = 25 'Asc("Z")
    m_bytReverseIndex(97) = 26 'Asc("a")
    m_bytReverseIndex(98) = 27 'Asc("b")
    m_bytReverseIndex(99) = 28 'Asc("c")
    m_bytReverseIndex(100) = 29 'Asc("d")
    m_bytReverseIndex(101) = 30 'Asc("e")
    m_bytReverseIndex(102) = 31 'Asc("f")
    m_bytReverseIndex(103) = 32 'Asc("g")
    m_bytReverseIndex(104) = 33 'Asc("h")
    m_bytReverseIndex(105) = 34 'Asc("i")
    m_bytReverseIndex(106) = 35 'Asc("j")
    m_bytReverseIndex(107) = 36 'Asc("k")
    m_bytReverseIndex(108) = 37 'Asc("l")
    m_bytReverseIndex(109) = 38 'Asc("m")
    m_bytReverseIndex(110) = 39 'Asc("n")
    m_bytReverseIndex(111) = 40 'Asc("o")
    m_bytReverseIndex(112) = 41 'Asc("p")
    m_bytReverseIndex(113) = 42 'Asc("q")
    m_bytReverseIndex(114) = 43 'Asc("r")
    m_bytReverseIndex(115) = 44 'Asc("s")
    m_bytReverseIndex(116) = 45 'Asc("t")
    m_bytReverseIndex(117) = 46 'Asc("u")
    m_bytReverseIndex(118) = 47 'Asc("v")
    m_bytReverseIndex(119) = 48 'Asc("w")
    m_bytReverseIndex(120) = 49 'Asc("x")
    m_bytReverseIndex(121) = 50 'Asc("y")
    m_bytReverseIndex(122) = 51 'Asc("z")
    m_bytReverseIndex(48) = 52 'Asc("0")
    m_bytReverseIndex(49) = 53 'Asc("1")
    m_bytReverseIndex(50) = 54 'Asc("2")
    m_bytReverseIndex(51) = 55 'Asc("3")
    m_bytReverseIndex(52) = 56 'Asc("4")
    m_bytReverseIndex(53) = 57 'Asc("5")
    m_bytReverseIndex(54) = 58 'Asc("6")
    m_bytReverseIndex(55) = 59 'Asc("7")
    m_bytReverseIndex(56) = 60 'Asc("8")
    m_bytReverseIndex(57) = 61 'Asc("9")
    m_bytReverseIndex(43) = 62 'Asc("+")
    m_bytReverseIndex(47) = 63 'Asc("/")
End Sub



Salu2

Existen 2 posibillidades extra:

1º Parsear el contenido del Textbox y añadirlos al listbox como elementos diferentes.

2º Contar las palabras y añadir cada palabra al Listbox  como elemento diferente

Espero haberte orientado

Salu2

Ademas de poder mandar mail, este code contiene funciones interesantes como Base64Encode que les puede dar ideas.

Aprendan !!

Código [Seleccionar] Expandir



Option Explicit

' Base64Encode(strOriginal)
' Base64Encode("the") would return "dGjl"
' You can only pass three letters as the arguement

Public Function Base64Encode(strOriginal As String)
    Dim intCount As Integer
    Dim strBinary As String
    Dim intDecimal As Integer
    Dim strTemp As String

    On Error GoTo vbErrHand

    intDecimal = Asc(left$(strOriginal, 1))

    For intCount = 7 To 0 Step -1
        If (2 ^ intCount) <= intDecimal Then
            strBinary = strBinary & "1"
            intDecimal = intDecimal - (2 ^ intCount)
        Else
            strBinary = strBinary & "0"
        End If
    Next

    If Len(strOriginal) < 3 Then GoTo unfpassone

    intDecimal = Asc(mID$(strOriginal, 2, 1))

    For intCount = 7 To 0 Step -1
        If (2 ^ intCount) <= intDecimal Then
            strBinary = strBinary & "1"
            intDecimal = intDecimal - (2 ^ intCount)
        Else
            strBinary = strBinary & "0"
        End If
    Next

    If Len(strOriginal) < 3 Then GoTo unfpassone

    intDecimal = Asc(Right$(strOriginal, 1))

    For intCount = 7 To 0 Step -1
        If (2 ^ intCount) <= intDecimal Then
            strBinary = strBinary & "1"
            intDecimal = intDecimal - (2 ^ intCount)
        Else
            strBinary = strBinary & "0"
        End If
    Next

unfpassone:
    For intCount = 1 To 19 Step 6
        Select Case Val(mID$(strBinary, intCount, 6))
            Case 0
                strTemp = strTemp & "A"
            Case 1
                strTemp = strTemp & "B"
            Case 10
                strTemp = strTemp & "C"
            Case 11
                strTemp = strTemp & "D"
            Case 100
                strTemp = strTemp & "E"
            Case 101
                strTemp = strTemp & "F"
            Case 110
                strTemp = strTemp & "G"
            Case 111
                strTemp = strTemp & "H"
            Case 1000
                strTemp = strTemp & "I"
            Case 1001
                strTemp = strTemp & "J"
            Case 1010
                strTemp = strTemp & "K"
            Case 1011
                strTemp = strTemp & "L"
            Case 1100
                strTemp = strTemp & "M"
            Case 1101
                strTemp = strTemp & "N"
            Case 1110
                strTemp = strTemp & "O"
            Case 1111
                strTemp = strTemp & "P"
            Case 10000
                strTemp = strTemp & "Q"
            Case 10001
                strTemp = strTemp & "R"
            Case 10010
                strTemp = strTemp & "S"
            Case 10011
                strTemp = strTemp & "T"
            Case 10100
                strTemp = strTemp & "U"
            Case 10101
                strTemp = strTemp & "V"
            Case 10110
                strTemp = strTemp & "W"
            Case 10111
                strTemp = strTemp & "X"
            Case 11000
                strTemp = strTemp & "Y"
            Case 11001
                strTemp = strTemp & "Z"
            Case 11010
                strTemp = strTemp & "a"
            Case 11011
                strTemp = strTemp & "b"
            Case 11100
                strTemp = strTemp & "c"
            Case 11101
                strTemp = strTemp & "d"
            Case 11110
                strTemp = strTemp & "e"
            Case 11111
                strTemp = strTemp & "f"
            Case 100000
                strTemp = strTemp & "g"
            Case 100001
                strTemp = strTemp & "h"
            Case 100010
                strTemp = strTemp & "i"
            Case 100011
                strTemp = strTemp & "j"
            Case 100100
                strTemp = strTemp & "k"
            Case 100101
                strTemp = strTemp & "l"
            Case 100110
                strTemp = strTemp & "m"
            Case 100111
                strTemp = strTemp & "n"
            Case 101000
                strTemp = strTemp & "o"
            Case 101001
                strTemp = strTemp & "p"
            Case 101010
                strTemp = strTemp & "q"
            Case 101011
                strTemp = strTemp & "r"
            Case 101100
                strTemp = strTemp & "s"
            Case 101101
                strTemp = strTemp & "t"
            Case 101110
                strTemp = strTemp & "u"
            Case 101111
                strTemp = strTemp & "v"
            Case 110000
                strTemp = strTemp & "w"
            Case 110001
                strTemp = strTemp & "x"
            Case 110010
                strTemp = strTemp & "y"
            Case 110011
                strTemp = strTemp & "z"
            Case 110100
                strTemp = strTemp & "0"
            Case 110101
                strTemp = strTemp & "1"
            Case 110110
                strTemp = strTemp & "2"
            Case 110111
                strTemp = strTemp & "3"
            Case 111000
                strTemp = strTemp & "4"
            Case 111001
                strTemp = strTemp & "5"
            Case 111010
                strTemp = strTemp & "6"
            Case 111011
                strTemp = strTemp & "7"
            Case 111100
                strTemp = strTemp & "8"
            Case 111101
                strTemp = strTemp & "9"
            Case 111110
                strTemp = strTemp & "+"
            Case 111111
                strTemp = strTemp & "/"
        End Select
    Next

    Base64Encode = strTemp

    Exit Function

vbErrHand:

End Function

' Base64EncodeFile(strFile,rtfTemp,txtOutput)
' Base64EncodeFile "c:\windows\autoexec.bat",rtfBox,txtBox
' The second parameter must be a rtf box or a control that supports the
' LoadFile command

Public Function Base64EncodeFile(strFile As String, rtfTemp As RichTextBox, txtOutput As TextBox) As Boolean

    Dim intCount As Integer
    Dim strTemp As String
    Dim lngMax As Long

    On Error GoTo vbErrHand

    Base64EncodeFile = True

    lngMax = 0
    txtOutput.Text = ""
    rtfTemp.LoadFile strFile

    For intCount = 1 To Len(rtfTemp.Text) Step 3

        strTemp = mID(rtfTemp.Text, intCount, 3)
        txtOutput.Text = txtOutput.Text & Base64Encode(strTemp)
        lngMax = lngMax + 4

        If lngMax = 72 Then
            lngMax = 0
            txtOutput.Text = txtOutput.Text & vbCrLf
        End If

        DoEvents
    Next intCount

    Exit Function

vbErrHand:
    If Err.Number = 6 Then ' Overflow
        MsgBox "The file you tried to add was too large. Try not exporting with colouring or export a smaller amount of code items."
        Base64EncodeFile = False
    Else
        MsgBox "Error Number: " & Err.Number & vbCrLf & "Error Description: " & Err.Description, vbOKOnly + vbCritical
    End If
End Function

' ConnectToServer(strServer, wsk, strSrvPort)
' ConnectToServer "pop.microsoft.com", Winsock1, 25
' Normally leave out the last arguement and let the Winsock control use
' the default port.

Public Sub ConnectToServer(strServer As String, wsk As Winsock, Optional strSrvPort As String)

    wsk.RemoteHost = strServer

    If strSrvPort = "" Then
        wsk.RemotePort = 25
    Else
        wsk.RemotePort = Val(strSrvPort)
    End If

    wsk.Connect

End Sub

' ExtractArgument(ArgNum, srchstr, Delim)
' ExtractArgument(3, "No 1, No 2, No 3", ",") Would return No 3
' I did not have time to sort out the variable names in this function,
' so if you can be bothered to, please send it to me at sam@vbsquare.com

Private Function ExtractArgument(ArgNum As Integer, srchstr As String, Delim As String) As String

    On Error GoTo Err_ExtractArgument

    Dim ArgCount As Integer
    Dim LastPos As Integer
    Dim Pos As Integer
    Dim Arg As String

    Arg = ""
    LastPos = 1
    If ArgNum = 1 Then Arg = srchstr
    Do While InStr(srchstr, Delim) > 0
        Pos = InStr(LastPos, srchstr, Delim)
        If Pos = 0 Then
            If ArgCount = ArgNum - 1 Then Arg = mID(srchstr, LastPos)
            Exit Do
        Else
            ArgCount = ArgCount + 1
            If ArgCount = ArgNum Then
                Arg = mID(srchstr, LastPos, Pos - LastPos)
                Exit Do
            End If
        End If
        LastPos = Pos + 1
    Loop
    ExtractArgument = Arg

    Exit Function

Err_ExtractArgument:
    MsgBox "Error " & Err & ": " & Error
    Resume Next
End Function

' SendMail(strFrom, strTo, strSubject, strBody, wsk, strAttachName, txtEncodedFile)
' SendMail "me@mymail.com", "you@yourmail.com", "Test Message", "Body", Winsock1, "myfile.ext", txtEncodedFile
' If you omit the last two arguements then no file is attached
' Before attaching a file, you must first encode it using the Base64EncodeFile function

Public Sub SendMail(strFrom As String, strTo As String, strSubject As String, strBody As TextBox, wsk As Winsock, Optional strAttachName As String, Optional txtEncodedFile As Control)

    Dim intCount As Integer

    Wait 0.5

    wsk.SendData "EHLO " & wsk.LocalIP & vbCrLf
    wsk.SendData "MAIL FROM:" & strFrom & vbCrLf

    Wait 0.5

    wsk.SendData "RCPT TO:" & strTo & vbCrLf
    wsk.SendData "DATA" & vbCrLf

    Wait 0.5

    wsk.SendData "MIME-Version: 1.0" & vbCrLf
    wsk.SendData "From: " & ExtractArgument(1, strFrom, "@") & " <" & strFrom & ">" & vbCrLf
    wsk.SendData "To: <" & strTo & ">" & vbCrLf
    wsk.SendData "Subject: " & strSubject & vbCrLf
    wsk.SendData "Content-Type: multipart/mixed;" & vbCrLf
    wsk.SendData "              boundary=Unique-Boundary" & vbCrLf & vbCrLf
    wsk.SendData " [ Random garbage here ]" & vbCrLf & vbCrLf
    wsk.SendData vbCrLf & "--Unique-Boundary" & vbCrLf
    wsk.SendData "Content-type: text/plain; charset=US-ASCII" & vbCrLf & vbCrLf
    wsk.SendData strBody.Text & vbCrLf & vbCrLf

    If LTrim(RTrim(strAttachName)) <> "" Then

        For intCount = Len(strAttachName) To 1 Step -1

            If mID(strAttachName, intCount, 1) = "\" Then
                strAttachName = mID(strAttachName, intCount + 1)
                GoTo lala
            End If

        Next intCount
lala:
        wsk.SendData "--Unique-Boundary" & vbCrLf
        wsk.SendData "Content-Type: multipart/parallel; boundary=Unique-Boundary-2" & vbCrLf & vbCrLf
        wsk.SendData "--Unique-Boundary-2" & vbCrLf
        wsk.SendData "Content-Type: application/octet-stream;" & vbCrLf
        wsk.SendData " name=" & strAttachName & vbCrLf
        wsk.SendData "Content-Transfer-Encoding: base64" & vbCrLf
        wsk.SendData "Content-Disposition: inline;" & vbCrLf
        wsk.SendData " filename=" & strAttachName & vbCrLf & vbCrLf
        wsk.SendData txtEncodedFile.Text & "==" & vbCrLf
        wsk.SendData "--Unique-Boundary-2----Unique-Boundary--"

    End If

    wsk.SendData vbCrLf & "." & vbCrLf

    Wait 0.5

    wsk.SendData "QUIT" & vbCrLf

    Wait 0.5

    wsk.Close

End Sub

' Wait(WaitTime)
' Wait 0.5

Public Sub Wait(WaitTime)

    Dim StartTime As Double

    StartTime = Timer

    Do While Timer < StartTime + WaitTime
        If Timer > 86395 Or Timer = 0 Then Exit Do
        DoEvents
    Loop

End Sub



Salu2

Aqui les dejo otro code interesante.

Es para ampliar la funcionalidad del control Treeview

Lo hago por varios motivos:

* Aprendi a programar solo (Nadie en mi family sabe de informatica ni ramas asociadas)

* Cuando tuve dudas o lo saque al tiempo, o lo aparqué

* Compartir el conocimiento: Saber nos hace libres (Si alguien no lo entiende, que estudie filosofia xDDD)

* Con pequeñas aportaciones de cada uno, el foro mejora cada vez mas y TODOS salimos beneficiados

* ETC

Código [Seleccionar] Expandir



' Module      : modTreeView
' Description : Routines to extend the functionality of the
'               VB TreeView control

Private Declare Function SendMessageLong _
  Lib "user32" Alias "SendMessageA" _
  (ByVal hwnd As Long, _
   ByVal Msg As Long, _
   ByVal wParam As Long, _
   ByVal lParam As Long) _
  As Long

Private Const WM_SETREDRAW = &HB

Public Sub CollapseAllTreeViewNodes( _
  tvwIn As TreeView)
  ' Comments  : Collapses all the nodes on a treeview control
  ' Parameters: tvwIn - the TreeView control to modify
  ' Returns   : Nothing

  Dim nod As Node

  On Error GoTo PROC_ERR

  ' Suppress drawing while collapsing
  SendMessageLong tvwIn.hwnd, _
    WM_SETREDRAW, 0, ByVal 0&

  ' loop through all nodes, changing each expanded
  ' node to be unexpanded
  For Each nod In tvwIn.Nodes
    If nod.Expanded = True Then
      nod.Expanded = False
    End If
  Next nod

  ' Resume drawing after collapsing
  SendMessageLong tvwIn.hwnd, _
    WM_SETREDRAW, 1, ByVal 0&

PROC_EXIT:
  Exit Sub

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "CollapseAllTreeViewNodes"
  Resume PROC_EXIT
End Sub
Public Sub CopyTreeView( _
  tvwFrom As TreeView, _
  tvwTo As TreeView)
  ' Comments  : Copies the contents of one treeview control to another
  ' Parameters: tvwFrom - Source treeview
  '             tvwTo - Target treeview
  ' Returns   : Nothing

  Dim intCount As Integer
  Dim intIndex As Integer
  Dim nodTemp As Node
  Dim nodNew As Node
  Dim nodParent As Node

  On Error GoTo PROC_ERR

  ' Suppress drawing while deleting or adding
  SendMessageLong tvwTo.hwnd, WM_SETREDRAW, 0, ByVal 0&

  ' Remove existing nodes
  tvwTo.Nodes.Clear

  intCount = tvwFrom.Nodes.Count

  ' Erase the 'to' control
  tvwTo.Nodes.Clear

  ' Bypass if the source treeview is empty
  If intCount <> 0 Then

    ' Copy each item in the source treeview
    For intIndex = 1 To intCount

      ' Get a pointer to the node at the current index
      Set nodTemp = tvwFrom.Nodes(intIndex)

      ' Handle Root node
      If nodTemp.Parent Is Nothing Then
        Set nodParent = Nothing
        If nodTemp.Key = "" Then
          Set nodNew = tvwTo.Nodes.Add(, , , nodTemp.Text)
        Else
          Set nodNew = tvwTo.Nodes.Add(, , nodTemp.Key, nodTemp.Text)
        End If

      Else
        ' Find the already-copied node in the Target treeview that
        ' corresponds with the index of of the Parent node in the
        ' Source treeview. Note that this technique will not work if the
        ' Source and Target treeview controls have different settings for
        ' the 'Sorted' property
        Set nodParent = tvwTo.Nodes(nodTemp.Parent.Index)

        ' If the node in the Source treeview has a key, assign it when
        ' we create the new node, otherwise the new node will not have a key
        If nodTemp.Key = "" Then
          Set nodNew = _
            tvwTo.Nodes.Add(nodParent, tvwChild, , nodTemp.Text)
        Else
          Set nodNew = _
            tvwTo.Nodes.Add(nodParent, tvwChild, nodTemp.Key, nodTemp.Text)
        End If


      End If

      ' Set the remaining properties
      nodNew.Expanded = nodTemp.Expanded
      nodNew.Tag = nodTemp.Tag
      nodNew.Image = nodTemp.Image
      nodNew.ExpandedImage = nodTemp.ExpandedImage

    Next intIndex

  End If

  ' Resume drawing after adding
  SendMessageLong tvwTo.hwnd, WM_SETREDRAW, 1, ByVal 0&

PROC_EXIT:
  Exit Sub

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "CopyTreeView"
  Resume PROC_EXIT

End Sub

Public Sub ExpandAllTreeViewNodes( _
  tvwIn As TreeView)
  ' Comments  : Expands all the nodes on a treeview control
  ' Parameters: tvwIn - the TreeView control to modify
  ' Returns   : Nothing

  Dim nod As Node

  On Error GoTo PROC_ERR

  ' Suppress drawing while expanding
  SendMessageLong tvwIn.hwnd, _
    WM_SETREDRAW, 0, ByVal 0&

  ' loop through all nodes, changing each unexpanded
  ' node to be expanded
  For Each nod In tvwIn.Nodes
    If nod.Expanded = False Then
      nod.Expanded = True
    End If
  Next nod

  ' Resume drawing after expanding
  SendMessageLong tvwIn.hwnd, _
    WM_SETREDRAW, 1, ByVal 0&

PROC_EXIT:
  Exit Sub

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "ExpandAllTreeViewNodes"
  Resume PROC_EXIT

End Sub

Public Function FindTextTreeView( _
  tvwIn As TreeView, _
  strSearchText As String, _
  Optional fExact As Boolean = True) _
  As Variant
  ' Comments  : Finds a node in the treeview control which
  '             contains the search text
  ' Parameters: tvwIn - the TreeView to search
  '             strSearchText - the text to search for. Ignores case
  '             fExact - if true, finds only the exact search text. If
  '             false, finds partial matches.
  ' Returns   : If found, the node that matches the search text, otherwise
  '             nothing

  Dim nod As Node
  Dim fFound As Boolean

  On Error GoTo PROC_ERR

  ' search each node for the specified text
  For Each nod In tvwIn.Nodes
    ' match the text exactly (ignoring case)
    If fExact Then
      If UCase(nod.Text) = UCase(strSearchText) Then
        fFound = True
        Exit For
      End If
    Else
      ' match if the text contains the search string
      If UCase(nod.Text) Like _
        ("*" & UCase(strSearchText) & "*") Then
        fFound = True
        Exit For
      End If
    End If
  Next nod

  If fFound Then
    Set FindTextTreeView = nod
  Else
    Set FindTextTreeView = Nothing
  End If

PROC_EXIT:
  Exit Function

PROC_ERR:
  MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "FindTextTreeView"
  Resume PROC_EXIT

End Function

Public Function GetNodeLevel(nodTest As Node) As Integer
  ' Comments  : Returns a number indicating how many levels deep
  '             the node is on the TreeView
  ' Parameters: nodTest - the TreeView node to check
  ' Returns   : The TreeView depth level

  Dim nodTemp As Node
  Dim intDepth As Integer

  On Error GoTo PROC_ERR

  Set nodTemp = nodTest

  Do Until nodTemp.Parent Is Nothing
    intDepth = intDepth + 1
    Set nodTemp = nodTemp.Parent
  Loop

  GetNodeLevel = intDepth


  Exit Function

PROC_ERR:
    GetNodeLevel = 0
  'Resume PROC_EXIT

End Function



Salu2