Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: coco en Diciembre 14, 2011, 05:30:46 pm
-
Bueno, yo no uso OCX, creo que ya lo sabran todos.. Pero aca dnode laburo, si. Por tal motivo, tuve que hacer un codigo que permita scrollear los MSHFlexGrids (y Listbox).
La opcion mas sencilla era hacer un hook al Mouse, que de hecho, funciona bien. El problema es que en la aplicacion, se corren sentencias SQL muy raras, que hacen que el soft quede trabado unos segundos...
Dicha situacion hace que el sistema no le de mas bolilla al Wide Hook que puse en la aplicacion.
Solucion? Wide Hook del WH_WNDPROC (copiado mas o menos del ejemplo del Skinner de Leandro). Con eso, se puede obtener los mensajes de todas las ventanas del ThreadID actual (VB usa un solo thread, asi que uso eso como filtro; si no, caerian mensajes de todas las ventanas de windows).
En fin, la gracia de esto es no usar una funcion para cada objeto (ni cada form que contenga uno), ya que esto es global (a nivel de la aplicacion) y no requiere que el objeto tenga foco.
V2!
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type CWPSTRUCT
lParam As Long
wParam As Long
message As Long
hWnd As Long
End Type
Private Enum HookConstants
HC_ACTION = 0
HC_GETNEXT = 1
HC_SKIP = 2
HC_NOREMOVE = 3
HC_NOREM = HC_NOREMOVE
HC_SYSMODALOFF = 5
HC_SYSMODALON = 4
End Enum
Private Const WH_MOUSE_LL As Long = 14
Private Const WH_CALLWNDPROC As Long = 4
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const WM_VSCROLL As Long = &H115
Private Const GWL_WNDPROC As Long = (-4)
Private Const WM_CREATE As Long = &H1
Private Const WM_DESTROY As Long = &H2
'* The SetWindowsHookEx function installs an application-defined hook procedure into a hook chain. You would install a hook procedure to monitor the system for certain types of events. These events are associated either with a specific thread or with all threads in the system.
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
'* The UnhookWindowsHookEx function removes a hook procedure installed in a hook chain by the SetWindowsHookEx function.
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
'* The CallNextHookEx function passes the hook information to the next hook procedure in the current hook chain. A hook procedure can call this function either before or after processing the hook information.
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 Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
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 GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private m_lHook As Long
Private Function HookProc(ByVal uCode As Long, ByVal wParam As Long, lParam As CWPSTRUCT) As Long
On Local Error Resume Next ' No use of a event handler in hooking procedures
Dim ptMouse As POINTAPI
HookProc = CallNextHookEx(m_lHook, uCode, wParam, lParam)
' si es un mensaje de mouse wheel, agarrarlo
If (uCode = HC_ACTION) And (lParam.message = WM_MOUSEWHEEL) Then
' obtener posicion del mouse
Call GetCursorPos(ptMouse)
' scrollear flex
Call DoGenericScroll(WindowFromPoint(ptMouse.x, ptMouse.y), lParam.wParam < 0)
End If
End Function
Private Sub DoGenericScroll(ByVal lWndUnderMouse As Long, ByVal bUp As Boolean)
Dim lVScrollWnd As Long
Dim lParentWnd As Long
' Obtiene el Hwnd de la barra de Scroll vertical del DataGrid
lVScrollWnd = FindWindowEx(lWndUnderMouse, 0, "ScrollBar", "DataGridSplitVScroll")
' ver que tipo de clase es
Select Case WndClass(lWndUnderMouse)
Case "DataGridWndClass", "MSHFlexGridWndClass", "MSFlexGridWndClass", _
"ThunderTextBox", "ThunderRT6TextBox", "ThunderListBox", "ThunderRT6ListBox"
Case "ThunderComboBox", "ThunderRT6ComboBox"
Case "Edit"
If (WndClass(GetParent(lWndUnderMouse)) = "ThunderComboBox") Or _
(WndClass(GetParent(lWndUnderMouse)) = "ThunderRT6ComboBox") Then
lWndUnderMouse = GetParent(lWndUnderMouse)
Else
Exit Sub
End If
Case Else: Exit Sub
End Select
Debug.Print "scroll: "; lVScrollWnd; " under: "; lWndUnderMouse
If Not (lVScrollWnd = 0) Then
SendMessage lWndUnderMouse, WM_VSCROLL, IIf(bUp, 1, 0), ByVal lVScrollWnd
Else ' no se encontro la barra... probar con scroll sin definir de donde viene
SendMessage lWndUnderMouse, WM_VSCROLL, IIf(bUp, 1, 0), ByVal 0&
End If
End Sub
Public Function StartMouseHook() As Boolean
If Not (m_lHook = 0) Then
Exit Function
End If
m_lHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookProc, 0, App.ThreadID)
StartMouseHook = Not (m_lHook = 0)
End Function
Public Function StopMouseHook() As Boolean
If m_lHook = 0 Then
Exit Function
End If
Call UnhookWindowsHookEx(m_lHook)
m_lHook = 0
StopMouseHook = True
End Function
Private Function WndClass(ByVal lHandle As Long) As String
Dim sBuffer As String * 256
WndClass = Left$(sBuffer, GetClassName(lHandle, sBuffer, 256))
End Function
Espero alguna respuesta! saludos
-
Hola, no se si esto pueda servirte, ni siquiera recuerdo de donde lo saqué pero lo vengo utilizando en todos mis aplicativos y hasta ahora no he tenido ningun problema.
Option Explicit
Declare Function CallWindowProc Lib "user32" Alias _
"CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal Msg As Long, _
wParam As Any, lParam As Any) As Long
Public Const WM_ACTIVATEAPP = &H1C
Public Const GWL_WNDPROC = -4
Global lpPrevWndProc As Long
Private Const WM_MOUSEWHEEL = &H20A
Private Const WM_VSCROLL As Integer = &H115
' Como utilizar este procedimiento
' Colocar esta instruccion en Form_Activate
' Hook Me.hWnd
' Al terminar, colocar esta en Form_Deactivate
' Unhook Me.hWnd
Public Sub Hook(ByVal gHW As Long)
'Coloca el Scroll
If Not EstoyEnIDE Then lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub Unhook(ByVal gHW As Long)
Dim temp As Long
'quita el scroll
If Not EstoyEnIDE Then temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
End Sub
Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim fFrm As Form
Dim x
Select Case uMsg
Case WM_MOUSEWHEEL
Set fFrm = GetForm(hw)
x = LCase(TypeName(fFrm.ActiveControl))
Select Case LCase(TypeName(fFrm.ActiveControl))
' Puedes agregar mas tipos de controles en este Case
Case "textbox", "datalist", "msflexgrid", "mshflexgrid", "datacombo", "dbcombo", "datagrid", "listbox", "combobox"
If wParam < 0 Then
'envia mediante SendMessage el comando para mover el Scroll hacia abajo
SendMessage fFrm.ActiveControl.hwnd, WM_VSCROLL, ByVal 1, ByVal 0
Else
'Mueve el scroll hacia arriba
SendMessage fFrm.ActiveControl.hwnd, WM_VSCROLL, ByVal 0, ByVal 0
End If
End Select
End Select
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
End Function
Private Function GetForm(ByVal hwnd As Long) As Form
For Each GetForm In Forms
If GetForm.hwnd = hwnd Then Exit Function
Next GetForm
Set GetForm = Nothing
End Function
La funcion EstoyEnIDE es complementaria y la tengo a nivel de módulo, tampoco sabría decirte de donde la obtuve pero tambien funciona.
Public Function EstoyEnIDE() As Boolean
'Deberia utilizarse para evitar problemas del Hook
On Error GoTo ErrHandler
'because debug statements are ignored when
'the app is compiled, the next statment will
'never be executed in the EXE.
Debug.Print 1 / 0
EstoyEnIDE = False
Exit Function
ErrHandler:
'If we get an error then we are
'running in IDE / Debug mode
EstoyEnIDE = True
End Function
Saludos
-
Hola erbuson, ese hookea un form. Mi codigo no solo hookea un form, sino que lo hace automaticamente cada vez que abris uno nuevo. Y se adapta al control que esta abajo del mouse, por ende.. con tan solo llamar a StartMouseHook, ya te habilita la funcionalidad en todos los forms. Lo que si, el tuyo cuenta para soporte de otros controles, el mio es una adaptacion de uno que habia visto en RVB. Tranquilamente se puede adaptar, lo que pasa es que no lo precisaba para eso.
Saludos!
-
yo uso hace mucho en un sistema un codigo de PSC, es una clase que hookea cualquier control que tenga scrollbars, podes usar multiples controles a la ves con la misma instancia de clase, para el flexgrid funciona perfecto y no creashea ya que es IDE safe. tambien le agrege unas lineas de codigo y lo adapte para que funcione el scroll en los controles datacombo, pero este control (horrible) ya lo he reemplazado completamente por el ComboBoxEx de Leandro.
saludos.