Ejemplos usando el Api de windows para Visual basic

215 - Usar la rueda del mouse en controles de Visual basic

Ejemplos para utilizar el Scroll del mouse en controles

Contenido

Actualización
Ejemplo 1 - Usarlo con Microsoft Flexgrid y Microsoft Hierarchical Flexgrid
Ejemplo 2 - Usarlo con controles DataGrid
Ejemplo 3 - Usarlo con ambos controles
Ejemplo 4 - Usarlo con controles Scrollbar
Relacionados

Actualizado

Este es un proyecto actualizado de todos los ejemplos de esta página para poder usar Mouse wheel en controles Microsoft flexgrid . Hierarchical flexgrid , Datagrid y controles ScrollBar horizontal y vertical usando un módulo de clase creado por Paul caton

El proyecto que está en el archivo zip tiene 3 formularios para cada uno.

Para poder usar el módulo de clase , se debe crear una instancia de las misma y mediante el método InitMouseWheel , pasarle como parámetro el Hwnd del objeto , por ejemplo

Option Explicit Dim cMouseW As clsMW Private Sub Form_Load() With cMouseW ' datagrids .InitMouseWheel DataGrid1.hWnd .InitMouseWheel DataGrid2.hWnd ' Flexgrids .InitMouseWheel MsHFlexgrid1.hWnd .InitMouseWheel MsFlexgrid1.hWnd ' scrollbars .InitMouseWheel VScroll1.hWnd End With

Descargar módulo de clase

Ejemplo 1 - Scroll en Flexgrid

Nota: este código está adaptado de un ejemplo de Leandro Ascierto

Para poder habilitar el Scroll a la grilla, se debe inicializar el hook pasándole como parámetro el Hwnd del control, por ejemplo :

call HookForm (El MSFlexGrid )

Para remover el hook y poder quitar el scroll, mediante la siguiente linea:

call UnHookForm ( El MSFlexGrid )

Controles

Agregar al proyecto un módulo bas que tiene la función que intercepta los mensajes de windows para poder capturar el momento en que se utiliza la rueda del mouse sobre el Flexgrid indicado

En el formulario añadir un control Microsoft Flexgrid y un Hierarchical flex

Código fuente en el formulario

Option Explicit Private Sub Form_Load() Dim i As Integer ' añade algunos items a las grillas For i = 1 To 50 MSHFlexGrid1.AddItem i MSFlexGrid1.AddItem i Next End Sub ' Instala el hook en el MSFlexGrid Private Sub MSFlexGrid1_GotFocus() HookForm MSFlexGrid1 End Sub ' elimina el hook Private Sub MSFlexGrid1_LostFocus() UnHookForm MSFlexGrid1 End Sub ' Instala el hook en el Hierarchical FlexGrid Private Sub MSHFlexGrid1_GotFocus() HookForm MSHFlexGrid1 End Sub ' elimina el hook Private Sub MSHFlexGrid1_LostFocus() UnHookForm MSHFlexGrid1 End Sub ' por las dudas que no se ejecutó el LostFocus, remueve los ganchos Private Sub Form_Unload(Cancel As Integer) UnHookForm MSHFlexGrid1 UnHookForm MSFlexGrid1 End Sub

Código fuente del módulo bas

Option Explicit ' declaraciones del api ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 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 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 SendMessage Lib "user32.dll" Alias "SendMessageA" ( _ ByVal hwnd As Long, _ ByVal Msg As Long, _ wParam As Any, lParam As Any) As Long ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Constantes ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Const GWL_WNDPROC = (-4) Private Const WM_MOUSEWHEEL = &H20A Private Const WM_VSCROLL As Integer = &H115 Dim PrevProc As Long Public Sub HookForm(Obj As Object) PrevProc = SetWindowLong(Obj.hwnd, GWL_WNDPROC, AddressOf WindowProc) End Sub Public Sub UnHookForm(Obj As Object) SetWindowLong Obj.hwnd, GWL_WNDPROC, PrevProc End Sub ' Procedimiento qie intercepta los mensajes de windows, en este caso para _ interceptar el uso del Scroll del mouse ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function WindowProc(ByVal hwnd As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam) If uMsg = WM_MOUSEWHEEL Then If wParam < 0 Then ' envia mediante SendMessage el comando para mover el Scroll hacia abajo SendMessage hwnd, WM_VSCROLL, ByVal 1, ByVal 0 Else ' Mueve el scroll hacia arriba SendMessage hwnd, WM_VSCROLL, ByVal 0, ByVal 0 End If End If End Function

2 - Con un DataGrid

Para usarlo con un dataGrid, el ejemplo es exactamente igual que en el caso anterior. La diferencia es que , en el procedimiento WindowProc, si se utiliza la función Api SendMessage para realizar el Scroll en la grilla, en este caso ( no se por qué ) genera un error ( Mirar el código fuente a continuación , para poder usarlo correctamente con la función SendMessage )

La única forma que se me ocurrío, es usando el Método Scroll que poseen los controles DataGrid

Es decir , cuando se intercepta el mensaje que se está moviendo la rueda hacia arriba, ejecutar la siguiente linea de código:

ElFormulario.DataGrid1.Scroll 0, 1

Para mover el scroll hacia abajo:

ElFormulario.DataGrid1.Scroll 0, -1

Lo molesto de esto, con respecto al ejemplo del FlexGRid, es que hay que referenciar al DataGrid desde el módulo, mediante el formulario que lo contiene, si no no se puede utilizar por que no se puede acceder al control en cuestión. Es decir si el Datagrid está en un form1, la linea seria : Form1.Datagrid.Scroll 0, 1

Agregar un DataGrid en un Form1 y agregar la referencia a Microsoft Activex data objects para poder acceder a ADO

Código fuente en el formulario

Option Explicit Dim WithEvents Rst As Recordset Private Sub DataGrid1_GotFocus() HookForm DataGrid1 End Sub Private Sub DataGrid1_LostFocus() UnHookForm DataGrid1 End Sub Private Sub Form_Load() Dim db As Connection Set db = New Connection db.CursorLocation = adUseClient ' Ruta de la base de datos Biblio.mdb db.Open "PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source= " & _ "C:\Archivos de programa\Microsoft Visual Studio\VB98\BIBLIO.MDB;" ' nuevo recordset Set Rst = New Recordset ' abre la consulta Rst.Open "select * from Authors", db, adOpenStatic, adLockOptimistic ' Enlaza el datagrid con el recordset Set DataGrid1.DataSource = Rst DataGrid1.MarqueeStyle = dbgHighlightRowRaiseCell End Sub Private Sub Form_Unload(Cancel As Integer) UnHookForm DataGrid1 End Sub

Código fuente en el módulo bas

Option Explicit ' declaraciones del api ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 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 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 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Constantes ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Const GWL_WNDPROC = (-4) Private Const WM_MOUSEWHEEL = &H20A Private Const WM_VSCROLL As Integer = &H115 Dim PrevProc As Long Public Sub HookForm(Obj As Object) PrevProc = SetWindowLong(Obj.hwnd, GWL_WNDPROC, AddressOf WindowProc) End Sub Public Sub UnHookForm(Obj As Object) SetWindowLong Obj.hwnd, GWL_WNDPROC, PrevProc End Sub ' Procedimiento para los mensajes de windows ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function WindowProc(ByVal hwnd As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam) If uMsg = WM_MOUSEWHEEL Then If wParam < 0 Then ' Scroll hacia abajo Form1.DataGrid1.Scroll 0, 1 Else ' Mueve el scroll hacia arriba Form1.DataGrid1.Scroll 0, -1 End If End If End Function

Usar el mismo ejemplo pero con SendMessage

Bueno después de investigar un poco di con la solución .

Para que no genere error y se puede usar el api SendMessage para manipular el Scroll, en el siguiente ejemplo se usa la función FindwindowEx para recuperar el Hwnd del Scroll del DataGrid.

Usándolo de esta forma, se puede subclasificar la ventana o formulario, y utilizarlo ( por lo menos en teoría ) con muchos DataGrid del mismo formulario o de otros que tenga el programa, simplemente haciendo la llamada a la función que instala el Hook e indicando el DataGrid para habilitar el scroll, y de esta manera no tener que usar el método scroll del Data Grid, y tampoco el formulario que lo contiene

Ejemplo

Colocar Dos DataGrid en el formulario

La referencia a Ado

Código fuente en el formulario

Option Explicit ' variable para el recordset Dim rst1 As Recordset Dim rst2 As Recordset ' Al recibir el foco instala el Hook para el datagrid1 Private Sub DataGrid1_GotFocus() HookForm DataGrid1 End Sub ' Elimina el Hook Private Sub DataGrid1_LostFocus() UnHookForm DataGrid1 End Sub ' Al recibir el foco instala el Hook para el datagrid2 Private Sub DataGrid2_GotFocus() HookForm DataGrid2 End Sub ' Remueve el hook Private Sub DataGrid2_LostFocus() UnHookForm DataGrid2 End Sub Private Sub Form_Load() Dim db As Connection ' nueva conexión ado Set db = New Connection db.CursorLocation = adUseClient ' Ruta de la base de datos Biblio.mdb db.Open "PROVIDER=Microsoft.Jet.OLEDB.3.51;Data Source= " & _ "C:\Archivos de programa\Microsoft Visual Studio\VB98\BIBLIO.MDB;" ' nuevo recordset Set rst1 = New Recordset Set rst2 = New Recordset ' abre la consulta rst1.Open "select * from Authors", db, adOpenStatic, adLockOptimistic rst2.Open "select * from Authors", db, adOpenStatic, adLockOptimistic ' Enlaza los dos datagrid con el recordset Set DataGrid1.DataSource = rst1 Set DataGrid2.DataSource = rst2 ' esto es opcional y es para seleccionar la fila completa _ y que no entre en edición al hacer un clic en la fila DataGrid1.MarqueeStyle = dbgHighlightRowRaiseCell DataGrid2.MarqueeStyle = dbgHighlightRowRaiseCell End Sub Private Sub Form_Unload(Cancel As Integer) ' elimina los hooks UnHookForm DataGrid1 UnHookForm DataGrid2 ' cierra los recordset If Not rst1 Is Nothing Then rst1.Close Set rst1 = Nothing End If If Not rst2 Is Nothing Then rst2.Close Set rst2 = Nothing End If End Sub

Código fuente en el módulo bas

Option Explicit ' declaraciones del api ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 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 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 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 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Constantes ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Const GWL_WNDPROC = (-4) Private Const WM_MOUSEWHEEL = &H20A Private Const WM_VSCROLL As Integer = &H115 Dim PrevProc As Long ' instala el hook para el datagrid indicado Public Sub HookForm(ElDataGrid As DataGrid) PrevProc = SetWindowLong(ElDataGrid.hWnd, GWL_WNDPROC, AddressOf WindowProc) End Sub Public Sub UnHookForm(ElDataGrid As DataGrid) SetWindowLong ElDataGrid.hWnd, GWL_WNDPROC, PrevProc End Sub ' Procedimiento para procesar los mensajes de windows ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function WindowProc(ByVal hWnd As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Dim HScroll As Long ' Obtiene el Hwnd de la barra de Scroll vertical del DataGrid HScroll = FindWindowEx(hWnd, 0, "ScrollBar", "DataGridSplitVScroll") If uMsg = WM_MOUSEWHEEL And HScroll <> 0 Then If wParam < 0 Then ' Scroll hacia abajo SendMessage hWnd, WM_VSCROLL, 1, ByVal HScroll Else ' Mueve el scroll hacia arriba SendMessage hWnd, WM_VSCROLL, 0, ByVal HScroll End If End If WindowProc = CallWindowProc(PrevProc, hWnd, uMsg, wParam, lParam) End Function

Ejemplo 3 - Usarlo con un DataGrid, un Microsoft FlexGrid y un Hierarchical Flexgrid

Este ejemplo es el rejunte de los otros con algunas pequeñas modificaciones, pero es practicamente igual.

En el zip, hay un poyecto que tiene un Form1 con dos DataGrid y dos FlexGrid.

vista del formulario con los controles

Nota: Para cargar los DataGrid, se usa la base de datos biblio.mdb ( por si te da error, verifica la ruta en el Connectionsctring)

Y para iniciar el Scroll llamar a la función Iniciar Scroll y para detenerlo DetenerScroll.

Por ejemplo esto inicia ( Dos DataGrid , un MsFlexGRid y un MsHFlexGrid )

  ' Inicia el Scroll para los dos DataGrid
  IniciarScroll DataGrid1
  IniciarScroll DataGrid2
  
  ' Inicia el Scroll para los FlexGrid
  IniciarScroll MSHFlexGrid1
  IniciarScroll MSFlexGrid1

y para detenerlo, pasar también el control como parámetro :

DetenerScroll MSFlexGrid1
'Etc...

Descargar

Ejemplo 4 - Ejemplo para usar la rueda del mouse en controles Scrollbar

Este otro código fuente, es similar a los anteriores pero para aplicarlos en un control Scrollbar horizontal y un scrollbar vertical.

Colocar en un formulario dos picturebox. El picture2 dentro del picture1, y en el picture1 dos Scrollbar , como se muestra en el siguiente gráfico :

El ejemplo carga una imagen en el picture2, y establece los scrollbar, el resultado seria este :

Y para poder activar o crear el hook que intercepta la rueda del mouse, se debe inicializar en el formLoad, pasándole como parámetro las dos barras de desplazamiento a la función Hook:

Hook VScroll1
Hook HScroll1

Código fuente en el formulario

Option Explicit Private Sub Form_Load() ' establece el hook para interceptar la rueda del mouse Hook VScroll1 Hook HScroll1 Picture2.AutoSize = True On Error Resume Next Picture2.Picture = LoadPicture("C:\WINDOWS\Web\Wallpaper\Windows XP.jpg") Err.Clear 'Inicializa los scrolbar (los posiciona y le da los valores max y Largchange ) Call EstablecerScrollBar End Sub Private Sub EstablecerScrollBar() Dim w As Single Dim h As Single 'Colocamos le picture2 en la parte superior izquierda dentro del Picture1 Picture2.Move 0, 0 'redimensinado del scrollbar w = GetSystemMetrics(SM_CXVSCROLL) * Screen.TwipsPerPixelX h = GetSystemMetrics(SM_CYHSCROLL) * Screen.TwipsPerPixelY HScroll1.Move 0, Picture1.ScaleHeight - h, Picture1.ScaleWidth - w, h VScroll1.Move Picture1.ScaleWidth - w, 0, w, Picture1.ScaleHeight 'Inicializa los scrolbar (valores Max y Largchange) HScroll1.LargeChange = 15 VScroll1.LargeChange = 15 HScroll1.Max = (Picture2.Width - Picture1.ScaleWidth + _ VScroll1.Width) / 120 + 1 VScroll1.Max = (Picture2.Height - Picture1.ScaleHeight + _ HScroll1.Height) / 120 + 1 HScroll1.ZOrder 0 VScroll1.ZOrder 0 End Sub Private Sub Form_Unload(Cancel As Integer) UnHook VScroll1 UnHook HScroll1 End Sub Private Sub HScroll1_Change() Picture2.Left = -HScroll1.Value * 120 End Sub Private Sub HScroll1_Scroll() HScroll1_Change End Sub Private Sub Picture2_GotFocus() VScroll1.SetFocus End Sub Private Sub VScroll1_Change() Picture2.Top = -CSng(VScroll1.Value) * 120 End Sub Private Sub VScroll1_Scroll() VScroll1_Change End Sub

Código fuente en un módulo bas

Option Explicit ' Funciones api para el Hook ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 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 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 SendMessage Lib "user32.dll" Alias "SendMessageA" ( _ ByVal hwnd As Long, _ ByVal Msg As Long, _ wParam As Any, lParam As Any) As Long ' para usar con el picturebox '''''''''''''''''''''''''''''''''''''' Public Declare Function GetSystemMetrics Lib "user32" ( _ ByVal nIndex As Long) As Long Public Const SM_CYHSCROLL = 3 Public Const SM_CXVSCROLL = 2 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Constantes y variables ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Const GWL_WNDPROC = (-4) Private Const WM_MOUSEWHEEL = &H20A Private Const WM_VSCROLL As Integer = &H115 Dim PrevProc As Long ' instala el hook Public Sub Hook(Obj As Object) PrevProc = SetWindowLong(Obj.hwnd, GWL_WNDPROC, AddressOf WindowProc) End Sub ' quita el hook Public Sub UnHook(Obj As Object) SetWindowLong Obj.hwnd, GWL_WNDPROC, PrevProc End Sub ' Procedimiento de ventana que chequea si se está usndo la rueda del scroll ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function WindowProc(ByVal hwnd As Long, _ ByVal uMsg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam) If uMsg = WM_MOUSEWHEEL Then If wParam < 0 Then 'Scroll hacia abajo SendMessage hwnd, WM_VSCROLL, ByVal 1, ByVal hwnd Else ' scroll hacia arriba SendMessage hwnd, WM_VSCROLL, ByVal 0, ByVal hwnd End If End If End Function

Nota: para que el scroll funcione, en el momento de usar la rueda, los scrollbar deben tener el foco, por eso , en el Picture2 (el que tiene la imagen cargada ) ... está la siguiente linea :

Private Sub Picture2_GotFocus()
    VScroll1.SetFocus
End Sub

Descargar

Enlaces relacionados

Dll Addin para usar la rueda del mouse en el IDE del visual basic

Buscar en Recursos vb