Foros del Web » Programación para mayores de 30 ;) » Programación General » Visual Basic clásico »

FAQ's de VB6

Estas en el tema de FAQ's de VB6 en el foro de Visual Basic clásico en Foros del Web. Modulo de Clase: --------------------------------------------------------- Option Explicit Private Const MAX_PATH& = 260 Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare ...

  #121 (permalink)  
Antiguo 27/01/2006, 11:31
Avatar de VisualGuallabo  
Fecha de Ingreso: marzo-2005
Mensajes: 288
Antigüedad: 15 años, 6 meses
Puntos: 2
Proceso repetido, finalizar asta dejar uno solo.

Modulo de Clase:
---------------------------------------------------------
Option Explicit
Private Const MAX_PATH& = 260
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId& Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long)
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal ProcessID As Long, ByVal ServiceFlags As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long

Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szexeFile As String * MAX_PATH
End Type
Public Sub KillProcess(ByVal ProcessID As Long)
Dim hp&
hp& = OpenProcess(1&, -1&, ProcessID)
TerminateProcess hp&, 0&
DoEvents
End Sub

Public Function FindWindowByClass(ByVal WindowClassName As String) As Long
FindWindowByClass = FindWindow(WindowClassName, vbNullString)
End Function

Public Function FindProcessByWindowClass(ByVal WindowClassName As String) As Long
Dim pid&
GetWindowThreadProcessId FindWindowByClass(WindowClassName), pid&
FindProcessByWindowClass = pid&
End Function

Public Function FindProcessByName(ByVal AppPath As String) As Long
Dim AppPaths, ProcessIds, ParentProcessIds, i As Integer
ListRunningApps AppPaths, ProcessIds, ParentProcessIds
i = FindInArray(AppPaths, AppPath)
If i = -1 Then
FindProcessByName = 0
Else
FindProcessByName = ProcessIds(i)
End If
End Function

Public Sub ListRunningApps(ByRef AppPaths, ByRef ProcessIds, ByRef ParentProcessIds)
Dim uProcess As PROCESSENTRY32
Dim rProcessFound As Long
Dim hSnapshot As Long
Dim szExename As String
Dim i As Integer
Const TH32CS_SNAPPROCESS As Long = 2&

AppPaths = Array()
ProcessIds = Array()
ParentProcessIds = Array()

uProcess.dwSize = Len(uProcess)
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
rProcessFound = ProcessFirst(hSnapshot, uProcess)

Do While rProcessFound
i = InStr(1, uProcess.szexeFile, Chr(0))
szExename = LCase$(Left$(uProcess.szexeFile, i - 1))
AppendToArray AppPaths, szExename
AppendToArray ProcessIds, uProcess.th32ProcessID
AppendToArray ParentProcessIds, uProcess.th32ParentProcessID
rProcessFound = ProcessNext(hSnapshot, uProcess)
Loop
End Sub
Public Function FindInArray(List As Variant, Item As Variant) As Integer
Dim i As Integer
For i = 0 To UBound(List)
If UCase("" & List(i)) = UCase("" & Item) Then
FindInArray = i
Exit Function
End If
Next
FindInArray = -1
End Function
Private Sub AppendToArray(List As Variant, Item As Variant)
ReDim Preserve List(UBound(List) + 1)
List(UBound(List)) = Item
End Sub
----------------------------
este codigo en un formulario.
--------------------------------
Option Explicit
Private NombreProceso, IdentificacionProceso, ParentIdentificacionProceso
Private PM As Class1, i As Integer

Function Ejecutandoce(name As String)
Dim Veces As Integer
Veces = 0
Set PM = New Class1
PM.ListRunningApps NombreProceso, IdentificacionProceso, ParentIdentificacionProceso
For i = 0 To UBound(NombreProceso)
If NombreProceso(i) = name Then
Veces = Veces + 1
End If
Next

If Veces = 1 Then Exit Function

For i = 0 To UBound(NombreProceso)
If NombreProceso(i) = name Then
PM.KillProcess IdentificacionProceso(i)
Veces = Veces - 1
If Veces = 1 Then Exit Function
DoEvents
End If
Next

End Function

'Ejemplo para dejar la calculadora una sola vez en proceso en caso de que se 'este ejecutando mas de una vez
Private Sub Command1_Click()
Ejecutandoce ("calc.exe")
End Sub
__________________
"No hay lenguaje de programación potente que sea inferior a otro semejante cuando existe un buen programador que lo defiende"

Yosvanis Cruz Alias VisualGuallabo
Ycruz
  #122 (permalink)  
Antiguo 27/01/2006, 15:35
Avatar de vbx3m  
Fecha de Ingreso: febrero-2005
Ubicación: Venezuela
Mensajes: 524
Antigüedad: 15 años, 8 meses
Puntos: 1
Como quitar los botones de un MDIForm (Parent)

Código:
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const GWL_STYLE = (-16)
Private Const MF_BYPOSITION = &H400
Private Const MF_REMOVE = &H1000
Private Declare Function DrawMenuBar Lib "user32" _
       (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" _
       (ByVal hMenu As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" _
         (ByVal hwnd As Long, _
         ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" _
         (ByVal hMenu As Long, _
         ByVal nPosition As Long, _
         ByVal wFlags As Long) As Long
Private Const SC_MINIMIZE As Long = &HF020&
Private Const SC_MAXIMIZE As Long = &HF030&
Private Const MF_BYCOMMAND = &H0&
Private Const SC_CLOSE = &HF060&

Private Sub MDIForm_Load()
Dim L As Long
Dim hMenu As Long
Dim menuItemCount As Long
L = GetWindowLong(Me.hwnd, GWL_STYLE)
L = L And Not (WS_MINIMIZEBOX)
L = L And Not (WS_MAXIMIZEBOX)
L = SetWindowLong(Me.hwnd, GWL_STYLE, L)
hMenu = GetSystemMenu(Me.hwnd, 0)
If hMenu Then
      Call RemoveMenu(hMenu, SC_MAXIMIZE, MF_BYCOMMAND)
      Call RemoveMenu(hMenu, SC_MINIMIZE, MF_BYCOMMAND)
     menuItemCount = GetMenuItemCount(hMenu)
      Call RemoveMenu(hMenu, menuItemCount - 1, _
                       MF_REMOVE Or MF_BYPOSITION)
     Call RemoveMenu(hMenu, menuItemCount - 2, _
                       MF_REMOVE Or MF_BYPOSITION)
     Call DrawMenuBar(Me.hwnd)
End If
End Sub
__________________
ホルヘ・ラファエル・マルティネス・レオン
  #123 (permalink)  
Antiguo 27/01/2006, 16:03
Avatar de vbx3m  
Fecha de Ingreso: febrero-2005
Ubicación: Venezuela
Mensajes: 524
Antigüedad: 15 años, 8 meses
Puntos: 1
Encender y Apagar Num, Caps y Scroll Lock

Código:
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
Private Declare Function SetKeyboardState Lib "user32" (lppbKeyState As Byte) As Long
Const VK_NUMLOCK = &H90
Const VK_SCROLL = &H91
Const VK_CAPITAL = &H14
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1
Dim o As OSVERSIONINFO
Dim NumLockState As Boolean
Dim ScrollLockState As Boolean
Dim CapsLockState As Boolean
Aca podemos modificar el estado

Código:
Private Sub Num_Lock_Click()
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
NumLockState = keys(VK_NUMLOCK)
If NumLockState <> True Then
    'Poner numlock a on
    If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        'Si es Win95
        keys(VK_NUMLOCK) = 1
        SetKeyboardState keys(0)
    ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        'Si es WinNT
        keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
        keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
    End If
 Else
'Poner Num_Lock a Off
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        keys(VK_NUMLOCK) = 0
        SetKeyboardState keys(0)
        ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
         keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
    End If
End If
End Sub
Lo demas es casi igual

Código:
Private Sub Caps_Lock_Click()
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
CapsLockState = keys(VK_CAPITAL)
If CapsLockState <> True Then
    If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        keys(VK_CAPITAL) = 1
        SetKeyboardState keys(0)
    ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
        keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
    End If
 Else
 If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        keys(VK_CAPITAL) = 0
        SetKeyboardState keys(0)
    ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
        keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
    End If
End If
End Sub
Código:
Private Sub Scroll_Lock_Click()
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
ScrollLockState = keys(VK_SCROLL)
If ScrollLockState <> True Then
    If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        keys(VK_SCROLL) = 1
        SetKeyboardState keys(0)
    ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
        keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
    End If
Else
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        keys(VK_SCROLL) = 0
        SetKeyboardState keys(0)
    ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
        keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
        keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
    End If
End If
End Sub
__________________
ホルヘ・ラファエル・マルティネス・レオン
  #124 (permalink)  
Antiguo 28/01/2006, 18:40
Avatar de Jad-Neo  
Fecha de Ingreso: octubre-2004
Mensajes: 344
Antigüedad: 16 años
Puntos: 0
Leer un Tag de un código HTML

Código:
Option Explicit
Option Compare Text

Function GetHTMLTag(ByVal Code As String, ByVal TagName As String) As String
Dim Inst1 As Long, Inst2 As Long
Dim opTagLen As Byte, clTagLen As Byte
Dim opTag As String, clTag As String

opTag = "<" & TagName & ">"
clTag = "</" & TagName & ">"
opTagLen = Len(opTag)
clTagLen = Len(clTag)

Inst1 = InStr(1, Code, opTag)
If Inst1 = 0 Then Exit Function 	      'Si no hay el Tag especificado se termina
Inst2 = InStr(Inst1 + opTagLen, Code, clTag)
If Mid(Code, Inst1 + opTagLen, _
        clTagLen) = clTag Then Exit Function  'Si hay etiqueta pero no hay
                                              'contenido [ej. <title></title>]
GetHTMLTag = Mid(Code, Inst1 + opTagLen, Inst2 - (Inst1 + opTagLen))
clTag = "": Code = ""
End Function
Esta función devuelve lo que esté escrito dentro del Tag que se especifique. NO hay que poner los símbolos de apertura y cierre del Tag (<> y </>).

NOTA: Es impresindible poner Option Compare Text para tratar mayusculas y minusculas igualmente
__________________
Nunca seas sabio en tu propia opinión.
  #125 (permalink)  
Antiguo 01/02/2006, 09:43
Avatar de VisualGuallabo  
Fecha de Ingreso: marzo-2005
Mensajes: 288
Antigüedad: 15 años, 6 meses
Puntos: 2
Ejecutar un programa y esperar que finalice

'en un from
Option Explicit

Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STILL_ACTIVE = &H103
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess&, ByVal bInheritHandle&, ByVal dwProcessId&) _
As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) _
As Long

Sub EsperarShell(sCmd As String)

Dim hShell As Long
Dim hProc As Long
Dim codExit As Long

' ejecutar comando
hShell = Shell(Environ$("Comspec") & " /c " & sCmd, 2)

' esperar a que se complete el proceso
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hShell)

Do
GetExitCodeProcess hProc, codExit
DoEvents
Loop While codExit = STILL_ACTIVE

End Sub
'Ejemplo
Private Sub Command1_Click()
EsperarShell ("calc.exe")
msgbox "termino"
End Sub
__________________
"No hay lenguaje de programación potente que sea inferior a otro semejante cuando existe un buen programador que lo defiende"

Yosvanis Cruz Alias VisualGuallabo
Ycruz
  #126 (permalink)  
Antiguo 06/02/2006, 09:50
Avatar de Frehley  
Fecha de Ingreso: junio-2005
Ubicación: Somewhere between Heaven and Hell
Mensajes: 415
Antigüedad: 15 años, 4 meses
Puntos: 0
Autentificar Usuario y password

Pregunta:
Como autorizar usuario por password usando ADO?
Respuesta:
Creamos un formulario con un text1, text2 y un cmd y pegamos este código (obviamente con la referencia a ADO y la base de datos ya armada):
Cita:
Private cn1 As ADODB.Connection
Private rsusuario As ADODB.Recordset
Private strconn1 As String

Private Sub Form_Initialize()

strconn1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\database.mdb"
Set cn1 = New ADODB.Connection

cn1.ConnectionString = strconn1
cn1.CursorLocation = adUseClient
cn1.Open

Set rsusuario = New ADODB.Recordset
rsusuario.Open "usuarios", cn1, adOpenDynamic, adLockOptimistic
End Sub

Private Sub Command1_Click()
On Error GoTo usermal
rsusuario.Find "usuario =" & "'" & Text1.Text & "'"
If rsusuario!password = Text2.Text Then
Form1.Show
vendedor = Text1.Text
Unload Me
Exit Sub
End If

usermal:
MsgBox "El usuario o el password es incorrecto"
End

End Sub
Espero les sirva
__________________
diegoz.com.ar

Última edición por Frehley; 18/04/2006 a las 19:13
  #127 (permalink)  
Antiguo 08/02/2006, 10:28
Avatar de VisualGuallabo  
Fecha de Ingreso: marzo-2005
Mensajes: 288
Antigüedad: 15 años, 6 meses
Puntos: 2
Registar extension con todas las de la Ley

Solo tienen que usar el procedimiento publico registrarExtension.
Modulo:
'LLamada a las Api de Windows (advapi32)
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
'Constantes
Const HKEY_CLASSES_ROOT = &H80000000
Const REG_SZ = 1 'Valor de cadena
Public Res As Long

'IconFile -Dirección del icono que va a tener la extensión.
'ExeFile -Dirección del programa con que se va abrir la extensión.
'ProgramName -Nombre con que se idectifica el programa.
'Extension - Extension que se va a registrar Ejemp Jpg (sin el pto)
'ExtensionDescripcion -La descripción del extension que se mostrara
'en el explorador Ejem "Winrar Archive" (Este es el caso de *.rar extesion del Winrar)
Public Sub registrarExtension(ByVal IconFile As String, ByVal ExeFile As String, ByVal ProgramName As String, ByVal Extension As String, ByVal ExtensionDescripcion As String)
On Error GoTo Fin
Dim SubKey As String, I As String, E As String
SubKey = Extension
'Crea la primera clave en el registro,por ejemplo .jpg con valor jpgPaint
I = IconFile
RegCreateKey HKEY_CLASSES_ROOT, "." & SubKey, Res
RegOpenKey HKEY_CLASSES_ROOT, "." & SubKey, Res
RegSetValueEx Res, "", 0, REG_SZ, ByVal SubKey & ProgramName, Len(SubKey & ProgramName)

'Crea la segunda clave en el registro,por ejemplo jpgPaint con valor jpgPaint
RegCreateKey HKEY_CLASSES_ROOT, SubKey & ProgramName, Res
RegOpenKey HKEY_CLASSES_ROOT, SubKey & ProgramName, Res
RegSetValueEx Res, "", 0, REG_SZ, ByVal ExtensionDescripcion, Len(ExtensionDescripcion)

'Crea la primera subclave en el registro llamada DefaultIcon,con la ruta del icono seleccionado D:\RegExt\Cube 2.ico O C:\AS.EXE,1
RegCreateKey HKEY_CLASSES_ROOT, SubKey & ProgramName & "\DefaultIcon", Res
RegOpenKey HKEY_CLASSES_ROOT, SubKey & ProgramName & "\DefaultIcon", Res
RegSetValueEx Res, "", 0, REG_SZ, ByVal I, Len(I)

'Crea la segunda y tercera subclaves en el registro llamadas open\command,con la ruta del programa seleccionado. Ejem: C:\AS.EXE,1
E = ExeFile & " %1"
RegCreateKey HKEY_CLASSES_ROOT, SubKey & ProgramName & "\shell\open\command", Res
RegOpenKey HKEY_CLASSES_ROOT, SubKey & ProgramName & "\shell\open\command", Res
RegSetValueEx Res, "", 0, REG_SZ, ByVal E, Len(E)
Fin:
End Sub
__________________
"No hay lenguaje de programación potente que sea inferior a otro semejante cuando existe un buen programador que lo defiende"

Yosvanis Cruz Alias VisualGuallabo
Ycruz
  #128 (permalink)  
Antiguo 13/02/2006, 08:37
Avatar de VisualGuallabo  
Fecha de Ingreso: marzo-2005
Mensajes: 288
Antigüedad: 15 años, 6 meses
Puntos: 2
De acuerdo Windows Dll (Dll estatica) con Vb

Esto era imposible para los programadores de Visual Basic. Pero gracias al
descubrimiento de Ron Petrusha ya nos he posible realizar nuestras Windows dll desde Vb.

El la web del Guille también se habla sobre el tema. y extiende el uso de estas dll a otros lenguajes.


Partiendo de este tema aporte un programa que se encarga de realizar todo el proceso Explicado por Ron Petrusha, ADEMAS DE NO REALIZAR cambios en el Directorio de Visual Basic.

Mi programa.

Comentarios a [email protected]

Saludos
__________________
"No hay lenguaje de programación potente que sea inferior a otro semejante cuando existe un buen programador que lo defiende"

Yosvanis Cruz Alias VisualGuallabo
Ycruz

Última edición por VisualGuallabo; 13/02/2006 a las 08:43
  #129 (permalink)  
Antiguo 13/03/2006, 16:33
 
Fecha de Ingreso: marzo-2004
Mensajes: 338
Antigüedad: 16 años, 7 meses
Puntos: 2
Información ¿Como obtengo direccion IP? || VB.NET

En el siguiente articulo se publica una sencilla manera de conseguir la ip de un equipo en visual basic .net. Podremos pasar como argumento cualquier host y se nos devolvera una lista con todas las ips configuradas en ese host.

1er metodo
-----------
http://www.elguille.info/colabora/NE..._ObtenerIP.htm

2º metodo
----------
http://www.elguille.info/colabora/pu...ALP_IPAddr.htm
__________________
SiMpLiFiKa
http://www.manitasdelweb.com

Última edición por chem; 13/03/2006 a las 16:42
  #130 (permalink)  
Antiguo 14/03/2006, 12:28
Avatar de GeoAvila
Colaborador
 
Fecha de Ingreso: diciembre-2003
Ubicación: Antigua Guatemala
Mensajes: 4.032
Antigüedad: 16 años, 10 meses
Puntos: 53
Impresora por defecto de los Datareport

¿como cambiar la impresora por defecto de los datareport?
http://www.forosdelweb.com/f69/cambiar-impresora-predeterminada-antes-datareport-377020/


nos vemos..
__________________
* Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ
Sitio http://www.geoavila.com twitter: @GeoAvila
  #131 (permalink)  
Antiguo 16/03/2006, 02:56
 
Fecha de Ingreso: marzo-2006
Mensajes: 38
Antigüedad: 14 años, 7 meses
Puntos: 0
Como manejar un sensor de movimiento conectado al puerto paralelo

Como seria la interfaz (placa controladora) que haga de nucleo entre el sensor de movimiendo y la pc; via el puerto paralelo?. Que tipo de sensor usar?
Utilizo VB6
Si esto no va aca sepan disculpar es mi primer post, muevalo si es necesario

Última edición por renga73; 16/03/2006 a las 03:06
  #132 (permalink)  
Antiguo 18/03/2006, 08:41
Avatar de culd  
Fecha de Ingreso: noviembre-2003
Mensajes: 959
Antigüedad: 16 años, 11 meses
Puntos: 19
Como pasar de un TextBox a otro pulsando ENTER

Cita:
Iniciado por GeoAvila
pregunta:
¿cómo pasar de un texto a otro usando Enter?
respuesta:
Insertar tres TextBox y escribir el siguiente código:
Código:
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
Private Sub Text3_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
otra forma:
Insertar tres TextBox, cambiar la propiedad KeyPreview del formulario a True y escribir el siguiente código:
Código:
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
Agrego algo mas facil, sensillo, y mas eficiente.

'---------------------------------
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Text2.SetFocus
End If
End Sub
'---------------------------------

Lo que hace es, al detectar que se aprieta el Ascii 13 (que es el ENTER), pone como foco el Text2, es decir, pone el cursor sobre el Text2.

Es mas eficiente que el SendKey, por que si se usa sendkey, lo que hace es emular que se aprieta el TAB... y si usan SendKey, van a tener que asignarle por ejemplo al Text1 TAB1 y al Text2 TAB2, osea la propiedad de propiedad TAB de cada textbox, hay que poner al siguiente text que se quiere que salte un numero consecutivo.
  #133 (permalink)  
Antiguo 24/03/2006, 11:40
Avatar de GeoAvila
Colaborador
 
Fecha de Ingreso: diciembre-2003
Ubicación: Antigua Guatemala
Mensajes: 4.032
Antigüedad: 16 años, 10 meses
Puntos: 53
click derecho sobre un Flexgrid saber Col's y Row's

Pregunta:
como saber la posición de flexgrid con el click derecho de mouse..

Respuesta:
http://www.forosdelweb.com/f69/boton-derecho-380369/

nos vemos..
__________________
* Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ
Sitio http://www.geoavila.com twitter: @GeoAvila
  #134 (permalink)  
Antiguo 28/03/2006, 11:45
 
Fecha de Ingreso: abril-2005
Mensajes: 351
Antigüedad: 15 años, 5 meses
Puntos: 3
ToolTipText Multiline

Modulo Class Para hacer ToolTipText multilineas y personalizados

http://www.geocities.com/sistec_de_juarez/ExTooltip/

Muy bueno
__________________
www.leandroascierto.com

Última edición por LeandroA; 28/03/2006 a las 11:54
  #135 (permalink)  
Antiguo 20/04/2006, 09:04
Avatar de VisualGuallabo  
Fecha de Ingreso: marzo-2005
Mensajes: 288
Antigüedad: 15 años, 6 meses
Puntos: 2
Sonrisa Programa que registra sus ocx y dll

Esta es una técnica que pongo mucho en practica y la voy a compartir con ustedes. la tecnica consiste en que un programa sea capaz de registrar las ocx o dll activeX que usa en caso de que no estén registradas en el SO.

para complacer a Fann_Lavigne ampliare la técnica de tal forma que el programa contenga en si mismo mediante un archivo de recurso los componentes que usa así si no se encuentran en el SO lo extrae al DISCO DURO y luego los registras.

1-Creando el archivo de recursos.
creamos un archivo *.txt con el contenido siguiente:

1 componente PRELOAD WinPaht.ocx

luego le cambiamos la extensión por *.rc y lo nombramos componect.rc

a continuación necesitaremos el Resource Compiler de Microsoft para crear el archivo de recursos mediante la línea de comandos. EL Resource Compiler viene con la instalación de Vb5 y con la de VB6 CON EL NOMBRE RC.EXE

para eso usaremos un *.bat que lo llamaremos crearrecurso.bat con el contenido siguiente:
RC.EXE componect.rc

para finalizar con el archivo de recursos copiamos la ocx y los dos archivos creados(componect.rc y crearrecurso.bat) en la carpeta donde se encuentra RC.EXE. y ejecutamos el *.bat. se creara el archivo componect.res que añadiremos a nuestro programa presionando Ctrl+D.

ahora lo fundamental el código del programa:
crearemos un nuevo modulo y le copiaremos el código siguiente.
'Requiere Win32 SDK functions to register/unregister any ActiveX component

Private Declare Function LoadLibraryRegister Lib "KERNEL32" Alias "LoadLibraryA" _
(ByVal lpLibFileName As String) As Long

Private Declare Function FreeLibraryRegister Lib "KERNEL32" Alias "FreeLibrary" _
(ByVal hLibModule As Long) As Long

Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long
Private Declare Function GetProcAddressRegister Lib "KERNEL32" Alias "GetProcAddress" _
(ByVal hModule As Long, _
ByVal lpProcName As String) As Long

Private Declare Function CreateThreadForRegister Lib "KERNEL32" Alias "CreateThread" _
(lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, _
ByVal lpparameter As Long, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long

Private Declare Function WaitForSingleObject Lib "KERNEL32" _
(ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long

Private Declare Function GetExitCodeThread Lib "KERNEL32" _
(ByVal hThread As Long, lpExitCode As Long) As Long

Private Declare Sub ExitThread Lib "KERNEL32" (ByVal dwExitCode As Long)

Private Const STATUS_WAIT_0 = &H0
Private Const WAIT_OBJECT_0 = ((STATUS_WAIT_0) + 0)

Public Enum REGISTER_FUNCTIONS
DllRegisterServer = 1
DllUnRegisterServer = 2
End Enum

Public Enum STATUS
[File Could Not Be Loaded Into Memory Space] = 1
[Not A Valid ActiveX Component] = 2
[ActiveX Component Registration Failed] = 3
[ActiveX Component Registered Successfully] = 4
[ActiveX Component UnRegistered Successfully] = 5
End Enum


Sub Main()
On Error GoTo error
Form1.Show
Exit Sub
error:
MsgBox "El programa creara el componente WinPaht.ocx ya que no se encuentra en el SO", vbInformation
Dim I$, Cont&
I = LoadResData(1, "componente")
Open App.Path & "\WinPaht.ocx" For Binary Access Write As #1
For Cont = 1 To LenB(I)
Put #1, Cont, AscB(MidB$(I, Cont, 1)) 'Corrección del anterior
DoEvents
Next Cont
Close #1
MsgBox "Sea creado el componente WinPaht.ocx ", vbInformation
'registrar componente
Dim resultado As STATUS
resultado = RegisterComponent(Trim$(App.Path & "\WinPaht.ocx"), DllRegisterServer)
If resultado = [File Could Not Be Loaded Into Memory Space] Then
MsgBox "El Archivo No Pudo Estar Cargado en Espacio de Memoria", vbExclamation
ElseIf resultado = [Not A Valid ActiveX Component] Then
MsgBox "Componente ActiveX no valido", vbExclamation
ElseIf resultado = [ActiveX Component Registration Failed] Then
MsgBox "El Registro del componente a fallado", vbExclamation
ElseIf resultado = [ActiveX Component Registered Successfully] Then
MsgBox "Componente ActiveX Registrado correctamente", vbExclamation
End If
Main
End Sub

Private Function RegisterComponent(ByVal FileName$, _
ByVal RegFunction As REGISTER_FUNCTIONS) As STATUS

Dim lngLib&, lngProcAddress&, lpThreadID&, fSuccess&, dwExitCode&, hThread&

If FileName = "" Then Exit Function

lngLib = LoadLibraryRegister(FileName)
If lngLib = 0 Then
RegisterComponent = [File Could Not Be Loaded Into Memory Space] 'Couldn't load component
Exit Function
End If

Select Case RegFunction
Case REGISTER_FUNCTIONS.DllRegisterServer
lngProcAddress = GetProcAddressRegister(lngLib, "DllRegisterServer")
Case REGISTER_FUNCTIONS.DllUnRegisterServer
lngProcAddress = GetProcAddressRegister(lngLib, "DllUnregisterServer")
Case Else
End Select

If lngProcAddress = 0 Then
RegisterComponent = [Not A Valid ActiveX Component]
If lngLib Then Call FreeLibraryRegister(lngLib)
Exit Function
Else
hThread = CreateThreadForRegister(ByVal 0&, 0&, ByVal lngProcAddress, ByVal 0&, 0&, lpThreadID)
If hThread Then
fSuccess = (WaitForSingleObject(hThread, 10000) = WAIT_OBJECT_0)
If Not fSuccess Then
Call GetExitCodeThread(hThread, dwExitCode)
Call ExitThread(dwExitCode)
RegisterComponent = [ActiveX Component Registration Failed]
If lngLib Then Call FreeLibraryRegister(lngLib)
Exit Function
Else
If RegFunction = DllRegisterServer Then
RegisterComponent = [ActiveX Component Registered Successfully]
ElseIf RegFunction = DllUnRegisterServer Then
RegisterComponent = [ActiveX Component UnRegistered Successfully]
End If
End If
Call CloseHandle(hThread)
If lngLib Then Call FreeLibraryRegister(lngLib)
End If
End If
End Function


para terminar solo tienen que ir a las propiedades del proyecto y poner como objeto inicial Sub Main
__________________
"No hay lenguaje de programación potente que sea inferior a otro semejante cuando existe un buen programador que lo defiende"

Yosvanis Cruz Alias VisualGuallabo
Ycruz

Última edición por VisualGuallabo; 20/04/2006 a las 09:17
  #136 (permalink)  
Antiguo 20/04/2006, 16:23
Avatar de vbx3m  
Fecha de Ingreso: febrero-2005
Ubicación: Venezuela
Mensajes: 524
Antigüedad: 15 años, 8 meses
Puntos: 1
Como apagar el monitor??

Código:
Private Const APAGA = 2&
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Sub Command1_Click()
Call SendMessage(Me.hWnd, &H112, &HF170&, ByVal APAGA)
End Sub
__________________
ホルヘ・ラファエル・マルティネス・レオン
  #137 (permalink)  
Antiguo 03/05/2006, 08:40
Avatar de culd  
Fecha de Ingreso: noviembre-2003
Mensajes: 959
Antigüedad: 16 años, 11 meses
Puntos: 19
RichTextBox: Buscar todas las palabras iguales que uno desee y cambiarle el color

Código:
'Este codigo fue programado por CULD
'-----------------------------------
'Lo que hace es... cambiar de color
'todas las palabras que encuentre
'en el RichTextBox que uno quiera.
'por el color que uno  quiera
'-----------------------------------
'Para llamar a la accion hay que usar
'Call Colorear(Palabra, "El RichTextBox", Color, 1)
'El Richtextbox es el nombre donde va a colorear
'El color tiene que ser en Hexadecimal (pueden cambiar el color de un label y copiar el codigo)
'La posicion por default siempre tiene que ser 1, si es que se quiere colorear desde el comienzo
'si se quiere colorear desde donde esta el cursor, hay que usar SelStart
Public Sub Colorear(Palabra As String, Objeto As Object, Color As String, Posicion As Long)
Dim Texto As String
Dim Estoy As Long
Texto = Objeto.Text

Estoy = InStr(Posicion, Texto, Palabra, vbTextCompare)
If Estoy > 0 Then
    'Se posiciona el cursor donde encontro la palabra
    Objeto.SelStart = Estoy - 1
    'Selecciona toda la palabra
    Objeto.SelLength = Len(Palabra)
    'Colorea la palabra
    Objeto.SelColor = Color
    'Pone en la posicion al final de la palabra
    Posicion = Estoy + Len(Palabra)
    'vuelve a llamar a la accion recursivamente para encontrar todas las palabras
    Call Colorear(Palabra, Objeto, Color, Posicion)
Else
    Exit Sub
End If
End Sub
  #138 (permalink)  
Antiguo 03/05/2006, 09:34
Avatar de VisualGuallabo  
Fecha de Ingreso: marzo-2005
Mensajes: 288
Antigüedad: 15 años, 6 meses
Puntos: 2
Ejecutar comandos de msdos y esperar que finalicen

-crearemos un proyecto exe standar.
-un TextBox de nombre=COMANDOS y con la propiedad MULTILINE=tRUE
-UN COMANDBUTTON
y copiaremos el codigo siguiente en el Form:

Cita:
Option Explicit

Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STILL_ACTIVE = &H103
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess&, ByVal bInheritHandle&, ByVal dwProcessId&) _
As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) _
As Long

Sub EjecutarCMDDOS(COMANDOS As String)

Dim hShell As Long
Dim hProc As Long
Dim codExit As Long

Open "Archivo.bat" For Output As #1
Print #1, COMANDOS
Close #1
' ejecutar comando
hShell = Shell(Environ$("Comspec") & " /c " & "Archivo.bat", vbNormalFocus)
' esperar a que se complete el proceso
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hShell)

Do
GetExitCodeProcess hProc, codExit
DoEvents
Loop While codExit = STILL_ACTIVE


MsgBox "El comando ha acabado"

On Error Resume Next
Kill "Archivo.bat"

End Sub
Private Sub Command1_Click()
EjecutarCMDDOS COMANDOS.Text
End Sub
__________________
"No hay lenguaje de programación potente que sea inferior a otro semejante cuando existe un buen programador que lo defiende"

Yosvanis Cruz Alias VisualGuallabo
Ycruz

Última edición por VisualGuallabo; 03/05/2006 a las 10:37
  #139 (permalink)  
Antiguo 12/05/2006, 06:20
Avatar de vbx3m  
Fecha de Ingreso: febrero-2005
Ubicación: Venezuela
Mensajes: 524
Antigüedad: 15 años, 8 meses
Puntos: 1
Cambiar Iconos del MsgBox

Modulo:
Código:
Option Explicit
Private Const WH_CBT As Long = &H5
Private Const HCBT_ACTIVATE As Long = &H5
Private Const STM_SETICON As Long = &H170
Private Const MODAL_WINDOW_CLASSNAME As String = "#32770"
Private Const SS_ICON As Long = &H3
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_CHILD As Long = &H40000000
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOZORDER As Long = &H4
Private Const STM_SETIMAGE As Long = &H172
Private Const IMAGE_CURSOR As Long = &H2
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadID As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal CodeNo As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "KERNEL32" () As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal ParenthWnd As Long, ByVal ChildhWnd As Long, ByVal ClassName As String, ByVal Caption As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As Any) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Boolean
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Type ANICURSOR
   m_hCursor As Long
   m_hWnd As Long
End Type
Private pHook As Long
Private phIcon As Long
Private pAniIcon As String
Public Function XMsgBox(ByVal Message As String, _
               Optional ByVal MBoxStyle As VbMsgBoxStyle = vbOKOnly, _
               Optional ByVal Title As String = "", _
               Optional ByVal hIcon As Long = 0&, _
               Optional ByVal AniIcon As String = "") As VbMsgBoxResult
   pHook = SetWindowsHookEx(WH_CBT, _
          AddressOf MsgBoxHookProc, _
                     App.hInstance, _
                 GetCurrentThreadId())
   phIcon = hIcon
   pAniIcon = AniIcon
   If Len(AniIcon) <> 0 Or phIcon <> 0 Then
      MBoxStyle = MBoxStyle And Not (vbCritical)
      MBoxStyle = MBoxStyle And Not (vbExclamation)
      MBoxStyle = MBoxStyle And Not (vbQuestion)
      MBoxStyle = MBoxStyle Or vbInformation
   End If
   XMsgBox = MsgBox(Message, MBoxStyle, Title)
End Function
Private Function MsgBoxHookProc(ByVal CodeNo As Long, _
                                ByVal wParam As Long, _
                                ByVal lParam As Long) As Long
   Dim ClassNameSize As Long
   Dim sClassName As String
   Dim hIconWnd As Long
   Dim M As ANICURSOR
   MsgBoxHookProc = CallNextHookEx(pHook, CodeNo, wParam, lParam)
   If CodeNo = HCBT_ACTIVATE Then
      sClassName = Space$(32)
      ClassNameSize = GetClassName(wParam, sClassName, 32)
      If Left$(sClassName, ClassNameSize) <> MODAL_WINDOW_CLASSNAME Then Exit Function
      If phIcon <> 0 Or Len(pAniIcon) <> 0 Then _
         hIconWnd = FindWindowEx(wParam, 0&, "Static", vbNullString)
      If phIcon <> 0 Then SendMessage hIconWnd, STM_SETICON, phIcon, ByVal 0&
      If Len(pAniIcon) Then AniCreate M, pAniIcon, hIconWnd, 0, 0
      UnhookWindowsHookEx pHook
   End If
End Function
Public Sub AniCreate(ByRef m_AniStuff As ANICURSOR, sAniName As String, hwndParent As Long, x As Long, y As Long)
   AniDestroy m_AniStuff
   With m_AniStuff
      .m_hCursor = LoadCursorFromFile(sAniName)
      If .m_hCursor Then
         .m_hWnd = CreateWindowEx(0, "Static", "", WS_CHILD Or WS_VISIBLE Or SS_ICON, ByVal 20, ByVal 20, 0, 0, hwndParent, 0, App.hInstance, ByVal 0)
         If .m_hWnd Then
            SendMessage .m_hWnd, STM_SETIMAGE, IMAGE_CURSOR, ByVal .m_hCursor
            SetWindowPos .m_hWnd, 0, x, y, 0, 0, SWP_NOZORDER Or SWP_NOSIZE
         Else
            DestroyCursor .m_hCursor
         End If
      End If
   End With
End Sub

Public Sub AniDestroy(ByRef m_AniStuff As ANICURSOR)
   With m_AniStuff
      If .m_hCursor Then _
         If DestroyCursor(.m_hCursor) Then .m_hCursor = 0
      If IsWindow(.m_hWnd) Then _
         If DestroyWindow(.m_hWnd) Then .m_hWnd = 0
   End With
End Sub
Form:

Código:
Option Explicit
Dim M As ANICURSOR
   
Private Sub CmdAniTest_Click()
   XMsgBox "Icono animado", vbInformation + vbYesNo, "Prueba", , App.Path & "\DINOSAUR.ANI"
End Sub

Private Sub CmdClearFormAni_Click()
   AniDestroy M
   CmdClearFormAni.Enabled = False
End Sub

Private Sub CmdFormAni_Click()
   AniCreate M, App.Path & "\3drbusy10.ani", Me.hwnd, 100, 78
   CmdClearFormAni.Enabled = True
End Sub

Private Sub CmdIconTest_Click()
   XMsgBox "Icono diferente", vbCritical + vbYesNo, "Prueba", PicBullsEye
End Sub ' el PicBullsEye es un picturebox
__________________
ホルヘ・ラファエル・マルティネス・レオン

Última edición por vbx3m; 12/05/2006 a las 06:26
  #140 (permalink)  
Antiguo 12/05/2006, 06:27
Avatar de vbx3m  
Fecha de Ingreso: febrero-2005
Ubicación: Venezuela
Mensajes: 524
Antigüedad: 15 años, 8 meses
Puntos: 1
Cambiar texto a botones de MsgBox

Modulo:

Código:
Public hHook As Long
Public Const WH_CALLWNDPROCRET = 12
Public Const GWL_HINSTANCE = (-6)
Private Type tagCWPRETSTRUCT
    lResult As Long
    lParam As Long
    wParam As Long
    message As Long
    hWnd As Long
End Type
Private Const WM_INITDIALOG = &H110
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
    (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
    (ByVal idHook As Long, ByVal lpfn As Long, _
    ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
    (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" _
    (ByVal hHook As Long, ByVal nCode As Long, _
    ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const IDABORT = 3
Private Const IDRETRY = 4
Private Const IDIGNORE = 5
Private Const IDYES = 6
Private Const IDNO = 7
Private Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" _
    (ByVal hDlg As Long, ByVal nIDDlgItem As Long, _
    ByVal lpString As String) As Long
Public Function CallWndRetProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lr As Long
    Dim s As tagCWPRETSTRUCT
    lr = CallNextHookEx(hHook, nCode, wParam, lParam)
    If (nCode < 0) Then
        CallWndRetProc = lr
        Exit Function
    End If
    Call CopyMemory(s, ByVal lParam, Len(s))
    If (s.message = WM_INITDIALOG) Then
        Call SetDlgItemText(s.hWnd, IDYES, "Aprobar")
        Call SetDlgItemText(s.hWnd, IDNO, "Rechazar")
        UnhookWindowsHookEx hHook
        lr = 0&
    End If
    CallWndRetProc = lr
End Function
Form:

Código:
   Dim hInst As Long
    Dim Thread As Long
    Dim i As Long
    hInst = GetWindowLong(Me.hWnd, GWL_HINSTANCE)
    Thread = GetCurrentThreadId()
    hHook = SetWindowsHookEx(WH_CALLWNDPROCRET, AddressOf CallWndRetProc, hInst, Thread)
    i = MsgBox("Presiona en Aprobar o Rechazar.", vbYesNo)
    If i = vbYes Then
        Label1 = "Has presionado en Aprobar"
    ElseIf i = vbNo Then
        Label1 = "Has presionado en Rechazar"
    End If
__________________
ホルヘ・ラファエル・マルティネス・レオン
  #141 (permalink)  
Antiguo 12/05/2006, 08:48
Avatar de vbx3m  
Fecha de Ingreso: febrero-2005
Ubicación: Venezuela
Mensajes: 524
Antigüedad: 15 años, 8 meses
Puntos: 1
Otra forma de crear DSN, modificarlo y eliminarlo

Código:
'Declaracion de constantes
Private Const ODBC_ADD_DSN = 1 
Private Const ODBC_CONFIG_DSN = 2 
Private Const ODBC_REMOVE_DSN = 3 
Private Const vbAPINull As Long = 0& 
#If Win32 Then
    Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" _
            (ByVal hwndParent As Long, ByVal fRequest As Long, _
             ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
#Else
    Private Declare Function SQLConfigDataSource Lib "ODBCINST.DLL" _
            (ByVal hwndParent As Integer, ByVal fRequest As Integer, ByVal _
            lpszDriver As String, ByVal lpszAttributes As String) As Integer
#End If
Para crear un DSN :

Código:
#If Win32 Then
    Dim intRet As Long
#Else
    Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String

'Driver de SQL Server 
strDriver = "SQL Server"
'Driver de MySQL StrDriver = "MySQL ODBC 3.51 Driver"
'Asignamos los parametros separados por null.
strAttributes = "SERVER=SomeServer" & Chr$(0)
strAttributes = strAttributes & "DESCRIPTION=Temp DSN" & Chr$(0)
strAttributes = strAttributes & "DSN=DSN_TEMP" & Chr$(0)
strAttributes = strAttributes & "DATABASE=nombredb" & Chr$(0)
strAttributes = strAttributes & "UID=" & Chr$(0) 
strAttributes = strAttributes & "PWD=" & Chr$(0)
'Para mostrar el diálogo usar Form1.Hwnd en vez de vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, strDriver, strAttributes)
If intRet Then
    MsgBox "DSN Creado"
Else
    MsgBox "Fallo en la creación"
End If

Para borrarlo :

Código:
#If Win32 Then
    Dim intRet As Long
#Else
    Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String
'Driver de SQL Server 
strDriver = "SQL Server"
'Drive de MySQL StrDriver = "MySQL ODBC 3.51 Driver"
'Asignamos los parametros separados por null.
strAttributes = "DSN=DSN_TEMP" & Chr$(0)
'Para mostrar el diálogo usar Form1.Hwnd en vez de vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, strDriver, strAttributes)
If intRet Then
    MsgBox "DSN Eliminado"
Else
    MsgBox "Fallo en el borrado"
End If
Para modificarlo:

Código:
#If Win32 Then
    Dim intRet As Long
#Else
    Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String

'Driver de SQL Server 
strDriver = "SQL Server"
'Drive de MySQL StrDriver = "MySQL ODBC 3.51 Driver"
'Asignamos los parametros separados por null.
strAttributes = "SERVER=OtroSomeServer" & Chr$(0)
strAttributes = strAttributes & "DESCRIPTION=Temp DSN modificado" & Chr$(0)
strAttributes = strAttributes & "DSN=DSN_TEMP" & Chr$(0)
strAttributes = strAttributes & "DATABASE=pubs" & Chr$(0)
strAttributes = strAttributes & "UID=sa" & Chr$(0)
strAttributes = strAttributes & "PWD=" & Chr$(0)

'Para mostrar el diálogo usar Form1.Hwnd en vez de vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_CONFIG_DSN, strDriver, strAttributes)
If intRet Then
    MsgBox "DSN Modificado"
Else
    MsgBox "Fallo en la modificacion"
End If
Si el DSN es para access :
- En vez de DATABASE debes usar DBQ y especificar el nombre completo de la base de datos, incluyendo el path y la extension.
- El UID por defecto es admin, aunque en la base de datos este en español y se llame administrador.
__________________
ホルヘ・ラファエル・マルティネス・レオン
  #142 (permalink)  
Antiguo 16/05/2006, 21:46
 
Fecha de Ingreso: abril-2005
Mensajes: 351
Antigüedad: 15 años, 5 meses
Puntos: 3
Nuevo Boton

GorditoButton.ocx
Hola este es mi primer Ocx y se trata de un botón con nuevas formas, tiene varias propiedades entre ellas

• Un efecto de Transparencia o texturizado
• Actuar como CheckButoon
• Reproducir un Gif (no es muy avanzado ya que algunos no los reproduce)
• Reproducir un wav (para crear un efecto de sonido)
• Mover un texto en forma de marquesina
• Abrir una Url o archivo
• Poder crear nuevas formas de botones


El Ocx Trae por defecto 6 formas diferentes de botones pero se les puede crear nuevas formas, cambiar el color, intensidad de color, fuente, etc.

Si bien me quedaron algunas cositas para corregir creo que esta muy bien, mas adelante para la versión 1.0.0.2 se corregirán. Y sepan disculpar si hay errores de ortografía ya que enzima que soy malo en castellano me la jugué a poner las propiedades en ingles

Este obviamente consumirá un poco mas de recursos que un botón normal pero el que quiere vista que le cueste

Quiero agradecer a todos los que me ayudaron cuando preguntaba en el foro especialmente a Luciano y [EX3] dos grandes amigos de www.canalvisualbasic.net

El Ocx viene acompañado de un ejemplo bien explicado y un archivo bat para que se les haga mas fácil registrar el Ocx

Así que ¡¡Atención!! (para que no digan que no anda) antes de probar el ejemplo primero ejecutar el archivo register.bat para registrar el Ocx

Bueno espero les guste y ayuden opinado para corregir los detalles que falten para así poder terminarlo (uno de ellos es el Accesskeys que ya masomenos lo tengo encaminado)
Dejo un link para las opiniones
http://www.forosdelweb.com/showthrea...95#post1549895

El link para descargarlo
http://ar.geocities.com/leandroascie...ditobutton.zip

Algunos ScreenShot






__________________
www.leandroascierto.com

Última edición por LeandroA; 16/05/2006 a las 21:54
  #143 (permalink)  
Antiguo 28/05/2006, 07:53
Avatar de GeoAvila
Colaborador
 
Fecha de Ingreso: diciembre-2003
Ubicación: Antigua Guatemala
Mensajes: 4.032
Antigüedad: 16 años, 10 meses
Puntos: 53
Pregunta:
¿como encriptar en MD5?

Respuesta:
http://www.forosdelweb.com/f69/aporte-codigo-para-encriptar-md5-397068/
__________________
* Antes de preguntar lee las FAQ, y por favor no hagas preguntas en las FAQ
Sitio http://www.geoavila.com twitter: @GeoAvila
  #144 (permalink)  
Antiguo 03/06/2006, 22:09
Avatar de Jad-Neo  
Fecha de Ingreso: octubre-2004
Mensajes: 344
Antigüedad: 16 años
Puntos: 0
Menús estilo OFFICE 2003 con los menús de VB.

Dado que es demasiado el texto y los pasos, lo tube que poner en mi espacio de MSN.

Verifiquen este link.
__________________
Nunca seas sabio en tu propia opinión.
  #145 (permalink)  
Antiguo 08/06/2006, 08:26
Avatar de culd  
Fecha de Ingreso: noviembre-2003
Mensajes: 959
Antigüedad: 16 años, 11 meses
Puntos: 19
Convertir un Path de nombre largo a nombre corto

Supongamos que tienen un PATH (ruta de carpeta) larga, como por ejemplo "C:\Archivos de programa\". Y por algun motivo, quieren acortarla, ejemplo "C:\ARCHIV~1\". Entonces creen un modulo y carguen, lo siguiente y utilicen esta funcion.

Código:
'----- Creado por CULD -----
'- Para llamar a esta funcion utilizar:
'Variable = AcortarPath(Ruta)
'- Donde RUTA es la ruta LARGA que se quiere acortar
'- IMPORTANTE: Si o si, la ruta debe existir en la PC, si no existe no puede acortar.

Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
    (ByVal lpszLongPath As String, ByVal lpszShortPath As String, _
    ByVal cchBuffer As Long) As Long

Public Function AcortarPath(Ruta As String) As String
Dim sBuf As String * 260
Dim i As Long

i = GetShortPathName(Ruta, sBuf, Len(sBuf))
AcortarPath = Left$(sBuf, i)
End Function
  #146 (permalink)  
Antiguo 08/06/2006, 08:31
Avatar de culd  
Fecha de Ingreso: noviembre-2003
Mensajes: 959
Antigüedad: 16 años, 11 meses
Puntos: 19
Convertir un Path de nombre corto a nombre largo

Supongamos que tienen un PATH (ruta de carpeta) corta, como por ejemplo "C:\ARCHIV~1\". Y por algun motivo, quieren alargarla, ejemplo "C:\Archivos de programa\". Entonces creen un modulo y carguen, lo siguiente y utilicen esta funcion.

Código:
'----- Creado por CULD -----
'----- Alargar Path -----
'- Para llamar a esta funcion utilizar:
'Variable = AlargarPath(Ruta)
'- Donde RUTA es la ruta CORTA que se quiere alargar
'- IMPORTANTE: Si o si, la ruta debe existir en la PC, si no existe no puede alargar.

Private Declare Function GetLongPathName Lib "kernel32" Alias "GetLongPathNameA" _
    (ByVal lpszShortPath As String, ByVal lpszLongPath As String, _
    ByVal cchBuffer As Long) As Long

Public Function AlargarPath(Ruta As String) As String
Dim sBuf As String * 260
Dim i As Long

i = GetLongPathName(Ruta, sBuf, Len(sBuf))
alargarpatch = Left$(sBuf, i)
End Function

Última edición por culd; 08/06/2006 a las 08:39
  #147 (permalink)  
Antiguo 15/06/2006, 10:40
jorevale
Invitado
 
Mensajes: n/a
Puntos:
Pasar datos de un campo MEMO a un campo TEXTO en Access

Hola amigos

Sabido es que el campo de tipo texto en Access no acepta más de 255 caracteres, de modo que si alguna vez queremos pasar de el contenido de un campo tipo Memo a un campo tipo Texto, nos será imposible.

Aquí les va un pequeño código que trunca la cadena de caracteres en el 250, con lo cual lo demás es posible.

Dim VCadena As String
Dim VCadenaAcum As String

Private Sub Command1_Click()
With TESTRA.datPrimaryRS
.Recordset.MoveFirst
Do While Not .Recordset.EOF = True
If IsNull(.Recordset!P) = True Then
.Recordset.MoveNext 'Si está vacío, obvia el registro
Else
VCadena = .Recordset!P 'Partimos del campo memo
VCadenaAcum = "" 'Seteamos a "" por el loop
VCadenaAcum = Mid(VCadena, 1, 250) 'Truncando cadena
.Recordset!Sort = VCadenaAcum 'Copiando al campo tipo texto
.Recordset.Update
.Recordset.MoveNext
End If
Loop
End With
End Sub

Salu2
  #148 (permalink)  
Antiguo 19/06/2006, 14:32
 
Fecha de Ingreso: abril-2005
Mensajes: 351
Antigüedad: 15 años, 5 meses
Puntos: 3
Este es un modulo clase que sirve para obtener las distintas figuras que se encuentran dentro de una imagen, este método es muy usado en varias aplicaciones tales como MSN Messenger, Messenger Yahoo! y otras, cuyo objetivo es acelerar y optimizar el manejo de imágenes sin tener que usar a menudo el método load Picture que abecés es algo lento, con esta clase solo vasta con cargar una sola ves la imagen en la memoria para luego separar cada cuadro y para aplicarlo a sus distintos usos. En el caso de MSN Messenger las imágenes las guarda dentro del ejecutable como archivo de recursos y en el de MSN Yahoo! Las guarda dentro de una carpeta junto a la aplicación para crear sus distintos skin
Esta clase también es útil a la hora de hacer OCX para crear controles personalizados y también porque no para hacer algún jueguito donde se requiere velocidad con el manejo de gráficos
Trabaja igual que el “PictureClip” (Microsoft PictureClip Controls 6.0) solo que no se requiere de un OCX y además posee un método Paint que elimina la mascara del cuadro
Estos son las clase de gráficos con los que trata el modulo

Fig(1)

Fig(2)

Fig(3)

Fig(4)


Solo basta con indicar el numero de columnas y el numero de fila y luego poder indicar el grafico en forma secuencial
Como veran la Fig(1) cuenta con 5 Columnas x 5 Filas si indicamos el numero 7 nos devolvera el boton de la columna 2 de la fila 2 (osea el signo ? de color verde)
En la Fig(2) cuenta con 79 columnas x 1 fila osea que en este caso cada numero del 1 al 79 sera correlativo a su imagen
importante todos graficos dentro de la imagen deven ser del mismo tamaño

ClassCuadros


Cita:

' Module : ClassCuadros
' Fecha : 19/06/2006 18:02
' Autor : Leandro Ascierto

Option Explicit
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (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 TransparentBlt Lib "msimg32.dll" (ByVal hDC 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreateIC Lib "GDI32.dll" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByRef lpInitData As Any) As Long
Private Declare Function MulDiv Lib "Kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Const LOGPIXELSX As Long = 88 ' Logical pixels/inch in X
Private Const LOGPIXELSY As Long = 90 ' Logical pixels/inch in Y


Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type

Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type

Dim m_Columnas As Integer
Dim m_Filas As Integer
Dim m_Picture As Picture
Dim m_DC As Long
Dim m_Left As Long
Dim m_Top As Long
Dim hBmp As Long, PictureDC As Long
Public Property Set Picture(ByVal New_Picture As Picture)
Call Descargar
'combierto a m_picture en un hdc compatible
Set m_Picture = New_Picture
PictureDC = CreateCompatibleDC(0)
Call SelectObject(PictureDC, m_Picture.Handle)
End Property

Public Property Let Columnas(ByVal New_Columnas As Integer)
m_Columnas = New_Columnas
End Property
Public Property Get CeldasCount()
CeldasCount = m_Columnas * m_Filas
End Property
Public Property Let Filas(ByVal New_Filas As Integer)
m_Filas = New_Filas
End Property

Public Property Get Cuadro(ByVal Celda As Integer) As StdPicture
Set Cuadro = Desglozar(Celda, True)
End Property

Public Function Paint(ByVal Celda As Integer, ByVal SourceHdc As Long, ByVal Left As Single, ByVal Top As Single, ByVal Transparent As Boolean)
m_DC = SourceHdc
m_Left = Left
m_Top = Top
Call Desglozar(Celda, False, Transparent)
End Function

Private Function Desglozar(Celda As Integer, Bitmap As Boolean, Optional Transparent As Boolean) As Picture
Dim Alto As Long, Ancho As Long
Dim X As Integer, Y As Integer, Nro As Single

'obtengo las imagenes en forma lineal
If Celda > (m_Columnas * m_Filas) Then Exit Function
X = Celda Mod m_Columnas
Nro = IIf(X = 0, (Celda / m_Columnas) - 1, (Celda / m_Columnas))
If X = 0 Then X = m_Columnas
Y = IIf(Int(Nro) <= Nro, Int(Nro) + 1, Nro)
'-----
'obtengo las medidas de los cuadros
Ancho = ConvertPixelHimetric(m_Picture.Width, True, True) / m_Columnas
Alto = ConvertPixelHimetric(m_Picture.Height, True, False) / m_Filas
'-----
Dim hDCMemory As Long

DeleteObject (hBmp) 'elimino el arrastre de la buelta anterior
'creo una nueva superficie para depositar la imagen
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(PictureDC, Ancho, Alto)
Call SelectObject(hDCMemory, hBmp)
'------
'pinto la nueva superficie con la imagen
BitBlt hDCMemory, -Ancho * (X - 1), -Alto * (Y - 1), Ancho * X, Alto * Y, PictureDC, 0, 0, vbSrcCopy

'Si es el metodo "Paint" pinto las superficie sobre el hdc indicado con la mascara transparente o no
If Bitmap = False Then
If Transparent Then
TransparentBlt m_DC, m_Left, m_Top, Ancho, Alto, hDCMemory, 0, 0, Ancho, Alto, GetPixel(PictureDC, 0, 0)
Else
BitBlt m_DC, m_Left, m_Top, Ancho, Alto, hDCMemory, 0, 0, vbSrcCopy
End If

Else

'Si es el metodo "Picture" combierto la superficie en un bitmap
Dim Pic As PicBmp, IID_IDispatch As GUID

'Fill GUID info
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With

'Fill picture info
With Pic
.Size = Len(Pic) ' Length of structure
.Type = vbPicTypeBitmap ' Type of Picture (bitmap)
.hBmp = hBmp ' Handle to bitmap
.hPal = m_Picture.hPal ' Handle to palette (may be null)
End With

'Create the picture
Call OleCreatePictureIndirect(Pic, IID_IDispatch, 1, Desglozar)

End If
'Elimino la superficie temporal creada
Call DeleteDC(hDCMemory)
End Function
Private Function ConvertPixelHimetric(ByVal inValue As Long, ByVal ToPix As Boolean, inXAxis As Boolean) As Long
Dim TempIC As Long, GDCFlag As Long
'rutina para obtener las medidas de la imagen en Himetric
Const HimetricInch As Long = 2540

TempIC = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)

If (TempIC) Then
If (inXAxis) Then GDCFlag = LOGPIXELSX Else GDCFlag = LOGPIXELSY

If (ToPix) Then
ConvertPixelHimetric = MulDiv(inValue, GetDeviceCaps(TempIC, GDCFlag), HimetricInch)
Else
ConvertPixelHimetric = MulDiv(inValue, HimetricInch, GetDeviceCaps(TempIC, GDCFlag))
End If
Call DeleteDC(TempIC)
End If
End Function

Private Sub Class_Terminate()
Call Descargar
End Sub
Private Sub Descargar()
On Error Resume Next
'elimino todos los objetos creados
Call DeleteObject(hBmp)
Call DeleteObject(m_Picture.Handle)
Call DeleteDC(PictureDC)
Set m_Picture = Nothing
End Sub

Un ejemplo para provar
Guarden la Fig(2) en el disco "C:\" con el nombre "caritas.bmp"

Cita:
Dim Icons As ClassCuadros 'declaro Icons como la clase
Private Sub Form_Load()
Set Icons = New ClassCuadros 'Inicializo
Set Icons.Picture = LoadPicture("C:\caritas.bmp") 'cargo el grafico
Icons.Columnas = 79 'indico las columnas
Icons.Filas = 1 ' indico las filas
Me.AutoRedraw = True 'importante para el metodo paint
'voy a obenter el icono de la columna 51 de la fila 1
Me.Picture = Icons.Cuadro(51) 'devuelve en bitmap
Icons.Paint 51, Me.hDC, 50, 0, True 'pinta sin la mascara
Icons.Paint 51, Me.hDC, 100, 0, False 'pinta con la mascara
End Sub

Private Sub Form_Unload(Cancel As Integer)
setIcons = Nothing 'lo quito de la memoria
End Sub
Parametros de metodo paint

Cita:
Objeto.Paint [numero de celda], [hdc del destino], [Left del destino], [Top del destino], [valor True o False sobre la transparencia de la mascara]
Un ejemplo para descargar
http://ar.geocities.com/leandroascie...assCuadros.zip

Mis Agradecimiento para todos lo que me ayudaron a terminarla
__________________
www.leandroascierto.com

Última edición por LeandroA; 19/06/2006 a las 15:21
  #149 (permalink)  
Antiguo 19/07/2006, 19:07
Avatar de Dark Wolf  
Fecha de Ingreso: julio-2006
Ubicación: En Uruguay
Mensajes: 32
Antigüedad: 14 años, 3 meses
Puntos: 0
¿Como crear un capturador de pantalla?

Cita:
'Capturar la pantalla entera o la ventana activa:

'Añada dos botones y escriba el siguiente código
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Sub Command1_Click()
'Captura la ventana activa
keybd_event 44, 0, 0&, 0&
End Sub

Private Sub Command2_Click()
'Captura toda la pantalla
keybd_event 44, 1, 0&, 0&
End Sub
  #150 (permalink)  
Antiguo 20/07/2006, 10:15
Avatar de Dark Wolf  
Fecha de Ingreso: julio-2006
Ubicación: En Uruguay
Mensajes: 32
Antigüedad: 14 años, 3 meses
Puntos: 0
Bueno, aquí esta mi primer manual, veremos como Copiar, pegar y cortar lo que haya escrito en un Text Box.

EMPECEMOS

Para comenzar creamos un nuevo form y le metemos tres Commands Botonns y un Text Box.
Luego le cambiamos el texto a los botones por: Copiar, Pegar y Cortar y en el textbox escribimos cualquier cosa, yo en este caso voy a poner "Esto es un ejemplo de Copiar, Pegar y Cortar"



Bien, ahora vamos a escribir el código.
En el Command 1(el de Copiar) escribimos esto:

Cita:
Private Sub Command1_Click()
Clipboard.Clear
Clipboard.SetText Text1.SelText
Text1.SetFocus
End Sub
En Command 2(de Pegar):

Cita:
Private Sub Command2_Click()
Text1.SelText = Clipboard.GetText()
Text1.SetFocus
End Sub
Y en Command 3(de Cortar):

Cita:
Private Sub Command3_Click()
Clipboard.SetText Text1.SelText
Text1.SelText = ""
Text1.SetFocus
End Sub


Y listo, ya tienes una aplicacion con estas tres funciones, puedes descargar el código fuente de este manual aquí


Manual por: Darkwolf
Atención: Estás leyendo un tema que no tiene actividad desde hace más de 6 MESES, te recomendamos abrir un Nuevo tema en lugar de responder al actual.
Respuesta

SíEste tema le ha gustado a 41 personas (incluyéndote)




La zona horaria es GMT -6. Ahora son las 20:46.