|
62
|
Programación / Programación Visual Basic / Re: Ayuda AutoClick
|
en: 26 Mayo 2006, 15:21 pm
|
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
|
|
|
63
|
Programación / Programación Visual Basic / Re: Aviso de carga de Programa
|
en: 26 Mayo 2006, 15:15 pm
|
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
|
|
|
64
|
Programación / Programación Visual Basic / Duda :Escribir en la BIOS
|
en: 26 Mayo 2006, 15:04 pm
|
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
|
|
|
67
|
Programación / Programación Visual Basic / Clase para cifrar/descifrar en Base64
|
en: 26 Mayo 2006, 05:04 am
|
Como creo que la Seguridad es IMPORTANTE... Aunque en realidad no existe xDDD No se quejaran, eh ? 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
|
|
|
68
|
Programación / Programación Visual Basic / Re: ayuda con list y textbox
|
en: 26 Mayo 2006, 04:55 am
|
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
|
|
|
69
|
Programación / Programación Visual Basic / Modulo para mandar correo
|
en: 26 Mayo 2006, 04:50 am
|
Ademas de poder mandar mail, este code contiene funciones interesantes como Base64Encode que les puede dar ideas. Aprendan !! 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
|
|
|
70
|
Programación / Programación Visual Basic / Modulo Ampliar funcinalidad TreeView
|
en: 26 Mayo 2006, 04:43 am
|
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 ' 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
|
|
|
|
|
|
|