Publicado: 18/Abr/2001
Actualizado: 21/Abr/2001
El código que te muestro a continuación puede servirte para añadir nuevos eventos a los formularios.
Si quieres, puedes modificar la clase para añadir nuevos eventos, aunque los que ahora mismo tiene, son más que suficientes para ampliar la funcionalidad de los formularios.A grandes rasgos, lo que la clase hace es subclasificar un formulario y usar eventos para "lanzar" los eventos que la clase produce, de forma que puedas saber, por ejemplo si la posición del formulario ha cambiado, si el ratón entra o sale del formulario, etc.
No te voy a explicar cómo funciona... (al menos por ahora), ya que llevo bastante tiempo queriendo publicar esta clase, (desde el 21 de Marzo de 1999), y no lo he hecho por la pereza que da algunas veces tener que explicar todo... espero que me disculpes y te prometo que algún día de estos explicaré cómo funciona todo...Para usar la clase, añade la clase: cWndSubclass.cls y el módulo: MSubClass.bas al proyecto y declara una variable con WithEvents, para poder interceptar los eventos producidos.
Al cargarse el formulario crea la instancia y asigna el formulario a subclasificar usando el método Hook.
Cuando descargues el formulario hay que llamar al mismo método, pero sin parámetros.Nota:
Es muy importante hacer la llamada al método Hook, (sin parámetros), al descargar el formulario, si no quieres que se quede el gancho perdido en el limbo.Nota adicional:
Te recomiendo guardar todo antes de probar a subclasificar, por lo que pueda ocurrir.
Los eventos que se añaden al formulario:
Esta es una lista de los eventos que produce la clase, además del procedimiento MSG al que irán a parar todos los mensajes no procesados.
Evento Descripción Activate Se ha restaurado el formulario. Deactivate Se ha minimizado el formulario. DisplayChange Ha cambiado la pantalla. FontChange La fuente ha cambiado. LowMemory Hay poca memoria. MenuSelected Se ha seleccionado un elemento de un menú. MouseEnter El cursor del ratón ha entrado en el formulario. MouseEnterOn El cursor del ratón ha entrado en el control especificado. MouseLeave El cursor del ratón ha salido del formulario. MouseLeaveOn El cursor del ratón ha salido del control indicado. MouseWheel Se está usando la rueda del ratón. Move Se ha movido el formulario. MSG Recibe los mensajes no interceptados por la clase. SetCursor El cursor del ratón está en otra ventana y no es capturado por el formulario. WindowPosChange Ha cambiado la posición del formulario, los valores son los extremos exactos con respecto a la pantalla. En el código de la clase, encontrarás explicación más amplia... realmente la descripción de cada mensaje... aunque en inglés, ya que está sacado de la MSDN library.
El código:
Este es el código del formulario, a continuación estará el código de la clase y del módulo BAS.
Espero que te sea de utilidad y que me mandes los comentarios que creas conveniente sobre esta clase y sobre todo las posibles mejoras y fallos que puedas encontrar... que, casi seguro que los habrá.Nos vemos.
Guillermo
P.S.
Usa este link para bajarte el listado de la clase y del formulario de prueba: subclass_form.zip 14.3 KB
Vamos a ver los listados completos.
En primer lugar el del formulario de prueba:
'------------------------------------------------------------------------------ ' Form de prueba (24/Nov/00) ' Revisado (probado) para publicar en mis páginas (18/Abr/01) ' ' Prueba de subclasificación de formularios para añadir nuevos eventos, etc. ' ' ©Guillermo 'guille' Som, 1998-2001 '------------------------------------------------------------------------------ Option Explicit Private WithEvents mSubclassForm As cWndSubclass Private Sub mSubclassForm_Activate() ' Cuando se activa Label2(2).Caption = "Activate" End Sub Private Sub mSubclassForm_Deactivate() ' Cuando se desactiva Label2(2).Caption = "Deactivate" End Sub Private Sub mSubclassForm_DisplayChange(ByVal BitsPerPixel As Long, ByVal cxScreen As Long, ByVal cyScreen As Long) ' DisplayChange End Sub Private Sub mSubclassForm_FontChange() ' FontChange End Sub Private Sub mSubclassForm_LowMemory() ' LowMemory End Sub Private Sub mSubclassForm_MenuSelected(ByVal mnuItem As Long, mnuFlags As eWSCMF, ByVal hMenu As Long) ' MenuSelected List1.AddItem "Has seleccionado el menú: " & mnuItem End Sub Private Sub mSubclassForm_MouseEnter() ' Cuando entra el ratón en el formulario Label1 = "MouseEnter" End Sub Private Sub mSubclassForm_MouseEnterOn(unControl As Object) ' Cuando entra el ratón en uno de los controles Label1.Caption = "MouseEnterOn: " & unControl.Name End Sub Private Sub mSubclassForm_MouseLeave() ' Cuando sale el ratón Label1 = "MouseLeave" End Sub Private Sub mSubclassForm_MouseLeaveOn(unControl As Object) ' Cuando sale el ratón de un control Label1.Caption = "MouseLeaveOn: " & unControl.Name End Sub Private Sub mSubclassForm_MouseWheel(ByVal wKeys As Long, ByVal zDelta As Long, ByVal xPos As Long, ByVal yPos As Long) ' Cuando se mueve la rueda del ratón Label2(2).Caption = "Se ha movido la rueda del ratón" End Sub Private Sub mSubclassForm_Move(ByVal wLeft As Long, ByVal wTop As Long) ' Cuando se mueve el formulario Label2(0).Caption = "Posición del formulario: Left= " & wLeft & ", Top= " & wTop End Sub Private Sub mSubclassForm_MSG(ByVal uMSG As eWSCWM, ByVal wParam As Long, ByVal lParam As Long) ' Se supone que aquí llegarán todos los mensajes no capturados. ' If uMSG = WM_MOVE Then ' List1.AddItem "Moviendo el formulario..." ' End If ' ' ' If uMSG = WM_SETFOCUS Then ' List1.AddItem "WM_SETFOCUS" ' ElseIf uMSG = WM_MOUSEWHEEL Then ' ' cuando se mueve la rueda del ratón (que tenga rueda, claro...) ' List1.AddItem "WM_MOUSEWHEEL" ' End If End Sub Private Sub mSubclassForm_SetCursor(unControl As Object, ByVal HitTest As eWSCHitTest, ByVal MouseMsg As Long) 'Label2(2).Caption = "SetCursor: " & unControl.Name & ", HitTest:" & HitTest & ", MouseMsg: " & MouseMsg End Sub Private Sub mSubclassForm_WindowPosChanged(ByVal wLeft As Long, ByVal wTop As Long, ByVal wWidth As Long, ByVal wHeight As Long) ' Cuando cambia la posición de la ventana Label2(1).Caption = "WndPosChanged: L:" & wLeft & ", T:" & wTop & ", W:" & wWidth & ", H:" & wHeight End Sub Private Sub Form_Load() Dim i As Long For i = 0 To 2 Label2(i).Caption = "" Next Set mSubclassForm = New cWndSubclass ' ' Iniciar la subclasificación mSubclassForm.Hook Me End Sub Private Sub Form_Unload(Cancel As Integer) ' Desactivar el gancho mSubclassForm.Hook End Sub Private Sub mnuAbrir_Click() Label2(2).Caption = "Has seleccionado el menú Abrir" End Sub Private Sub mnuGuardar_Click() Label2(2).Caption = "Has seleccionado el menú Guardar" End Sub Private Sub mnuSalir_Click() Label2(2).Caption = "Has seleccionado el menú Salir" If MsgBox("¿quieres terminar el programa?", vbYesNo + vbQuestion, "Cerrar el ejemplo") = vbYes Then Unload Me End If End SubEl código del módulo BAS:
'------------------------------------------------------------------------------ ' Módulo para subclasificación (subclassing) (26/Jun/98) ' Revisado (probado) para publicar en mis páginas (18/Abr/01) ' ' Modificado para usar con la clase CWndSubClass (21/Mar/99) ' ' ©Guillermo 'guille' Som, 1998-2001 ' ' Para más información sobre subclasificación: ' En la documentación de Visual Basic: ' Pasar punteros de función a los procedimientos de DLL y a las bibliotecas de tipos ' En la MSDN Library (o en la Knowledge Base): ' HOWTO: Subclass a UserControl ' Article ID: Q179398 ' HOWTO: Hook Into a Window's Messages Using AddressOf ' Article ID: Q168795 ' HOWTO: Build a Windows Message Handler with AddressOf in VB5 ' Article ID: Q170570 '------------------------------------------------------------------------------ Option Explicit ' Un array de la clase que se usará para subclasificar ventanas ' y el último elemento de clases en el array; empieza a contar por uno Private mWSC() As cWndSubclass ' Array de clases Private mnWSC As Long ' Número de ventanas subclasificadas Private Const GWL_WNDPROC = (-4&) Public 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 Public Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Public Function WndProc(ByVal hWnd As Long, ByVal uMSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long ' Los mensajes de windows llegarán aquí. ' Lo que hay que hacer es "capturar" los que se necesiten, ' en este caso se devuelven los mensajes a la clase, usando para ' ello un procedimiento público llamado unMSG con los siguientes parámetros: ' ByVal uMSG As Long, ByVal wParam As Long, ByVal lParam As Long ' ' Para un mejor uso, usar la clase en el formato: ' Dim WithEvents laClase As CWndSubClass ' Static i As Long ' Buscar el índice de esta clase en el array ' NOTA: Esto se hará para cada uno de los mensajes recibidos, ' por tanto, no sería conveniente tener demasiadas ventanas o controles ' subclasificados, con idea de que no tarde demasiado en procesarlos '$Por hacer: ' Sería conveniente poner un límite máximo de ventanas a subclasificar i = IndiceClase(hWnd) If i Then With mWSC(i) WndProc = CallWindowProc(.PrevWndProc, hWnd, uMSG, wParam, lParam) ' Producir el evento del mensaje recibido .unMSG uMSG, wParam, lParam End With End If End Function Public Sub Hook(ByVal WSC As cWndSubclass, ByVal unControl As Object) ' Subclasificar la ventana o control indicado '-------------------------------------------------------------------------- ' Nota: ' En este procedimiento no se hace chequeo de que el objeto pasado tenga ' la propiedad hWnd, ya que se comprueba en el método Hook de la clase, ' por tanto no se debería llamar a este método sin antes hacer una comprobación ' de que estamos pasando un objeto-ventana (que tenga la propiedad hWnd) ' ' Comprobar si ya está subclasificada esta ventana Dim claseActual As Long Dim claseLibre As Long ' Buscar el índice de esta clase en el array ' y si hay alguna clase liberada anteriormente claseActual = IndiceClase(unControl.hWnd, claseLibre) If claseActual = 0 Then ' Si hay un índice que ya no se usa... If claseLibre Then ' se usará ese índice claseActual = claseLibre Else ' Crear una nueva clase mnWSC = mnWSC + 1 ReDim Preserve mWSC(1 To mnWSC) claseActual = mnWSC End If End If ' Aquí se está haciendo referencia a una clase ya existente, ' para que no queden referencias "sueltas", en el evento Terminate de la clase ' se llama al procedimiento de liberación de la subclasificación en el que se ' borrará la referencia a la clase indicada, por tanto no se debería modificar ' esa forma de actuar. '-------------------------------------------------------------------------- ' Nota: ' En lugar de hacer una referencia a la clase, se podría usar un puntero a ' la misma usando ObjPtr, pero esto implicaría usar la función CopyMemory ' para poder acceder a las propiedades de la clase, y no sé si esto ' incrementaría el tiempo de procesamiento, pero... ' "los expertos" así lo hacen... así que se supone que tendrá sus ventajas; ' aunque si se siguen "las reglas" indicadas, no tendría que dar problemas. ' Además la intención de esta clase es formar parte de un componente (DLL) ' y el código no estaría disponible a las aplicaciones cliente... ' Por eso, te aconsejo que no hagas experimentos, ' si no sabes las consecuencias que esa pruebas pueden tener, el que avisa... ' ' Ver el siguiente artículo en la Knowledge Base de Microsoft para un ejemplo ' de un UserControl subclasificado usando punteros a objetos: ' HOWTO: Subclass a UserControl, Article ID: Q179398 ' Set mWSC(claseActual) = WSC ' Subclasificar la ventana, (form o control), pasada como parámetro y ' guardar el procedimiento anterior With mWSC(claseActual) .hWnd = unControl.hWnd .PrevWndProc = SetWindowLong(.hWnd, GWL_WNDPROC, AddressOf WndProc) End With End Sub Public Sub unHook(ByVal WSC As cWndSubclass) ' Des-subclasificar la clase indicada Static claseActual As Long ' Buscar el índice de esta clase en el array claseActual = IndiceClase(WSC.hWnd) ' Si ya estaba subclasificada esta clase If claseActual Then With mWSC(claseActual) ' Restaurar la función anterior de procesamiento de mensajes Call SetWindowLong(.hWnd, GWL_WNDPROC, .PrevWndProc) ' Poner a cero el indicador de que se está usando .hWnd = 0& End With ' Quitar la referencia a esta clase Set mWSC(claseActual) = Nothing ' Si es la última del array... If mnWSC = claseActual Then ' Eliminar este item y ajustar el array mnWSC = mnWSC - 1 ' Si no hay más, eliminar el array If mnWSC = 0 Then Erase mWSC Else ' Ajustar el número de elementos del array ReDim Preserve mWSC(1 To mnWSC) End If End If End If End Sub Private Function IndiceClase(ByVal elhWnd As Long, Optional ByRef Libre As Long = 0) As Long ' Este procedimiento buscará el índice de la clase que tiene el hWnd indicado ' También, si se especifica, devolverá el índice de una clase que esté libre. ' Nota: Es importante que el último parámetro sea por referencia, ' ya que en él se devolverá el valor del índice libre. ' Static i As Long IndiceClase = 0 ' Recorrer todo el array For i = 1 To mnWSC With mWSC(i) ' Si coinciden los hWnd, es que ya se está usando una subclasificación If .hWnd = elhWnd Then ' usar esta misma clase ' pero si el hWnd es cero, será uno libre If elhWnd = 0 Then Libre = i Else IndiceClase = i End If Exit For ' Comprobar si hay algún "hueco" en el array, ' por ejemplo de una clase previamente liberada. ' Hay que tener en cuenta que estos procedimientos están en un BAS ' y sus valores se mantienen entre varias llamadas a las clases. ElseIf .hWnd = 0& Then Libre = i End If End With Next End FunctionEl código de la clase:
'------------------------------------------------------------------------------ ' cSubclass (21/Mar/99) ' ' Clase para subclasificar ventanas (formularios o controles con hWnd) ' ' Última revisión: 08/Ago/99 ' Revisado (probado) para publicar en mis páginas (18/Abr/01) ' ' ©Guillermo 'guille' Som, 1999-2001 '------------------------------------------------------------------------------ ' Basado en el código de un ejemplo del 26/Jun/98 ' para detectar los mensajes del menú seleccionado. ' ' También he usado como fuente de inspiración un artículo de Francesco Balena: ' Subclass Forms to Create New Events ' Aunque no me gustó la forma de enfocar la forma de gestionar varias instancias ' de la clase y me decidí por el enfoque del array. ' La verdad es que algunos de los eventos producidos están "inspirados" en el ' artículo de Balena. ' Todo hay que decirlo: La clase casi la terminé antes de conseguir el código ' del citado artículo, si hubiese tenido ese código antes, seguramente la ' hubiese hecho de otra forma... ¡menos mal que no fue así! ' ya que al menos me "esforcé" en hacerlo por mis medios... '------------------------------------------------------------------------------ Option Explicit ' Para los TwipsPerPixels del objeto Screen Private twX As Long, twY As Long ' Para poder interceptar el mensaje WM_MOUSELEAVE Private mtTME As tTRACKMOUSEEVENT Private mWndType As Object ' La ventana que se subclasifica Private mhWnd As Long ' El hWnd de la ventana subclasificada Private mPrevWndProc As Long ' La función anterior de procesamiento ' de mensajes de la ventana a subclasificar '------------------------------------------------------------------------------ ' Enumeración con los mensajes de windows (Window Messages) ' ' Esta lista está sacada de WinUser.h, ' algunas declaraciones están en el fichero Win32API.txt ' ' En los casos que se indique #if ... es que son para otras versiones de Windows: ' #if(WINVER >= 0x0400) Será Windows NT 4 y superior y Windows 98 ' #if(WINVER >= 0x0500) Será Windows 2000 y superior (Windows NT 5) (creo) Public Enum eWSCWM WM_NULL = &H0 WM_CREATE = &H1 WM_DESTROY = &H2 WM_MOVE = &H3 WM_SIZE = &H5 WM_ACTIVATE = &H6 WM_SETFOCUS = &H7 WM_KILLFOCUS = &H8 WM_ENABLE = &HA WM_SETREDRAW = &HB WM_SETTEXT = &HC WM_GETTEXT = &HD WM_GETTEXTLENGTH = &HE WM_PAINT = &HF WM_CLOSE = &H10 WM_QUERYENDSESSION = &H11 WM_QUIT = &H12 WM_QUERYOPEN = &H13 WM_ERASEBKGND = &H14 WM_SYSCOLORCHANGE = &H15 WM_ENDSESSION = &H16 WM_SHOWWINDOW = &H18 WM_WININICHANGE = &H1A ' #if(WINVER >= 0x0400) WM_SETTINGCHANGE = WM_WININICHANGE ' #endif /* WINVER >= 0x0400 */ WM_DEVMODECHANGE = &H1B WM_ACTIVATEAPP = &H1C WM_FONTCHANGE = &H1D WM_TIMECHANGE = &H1E WM_CANCELMODE = &H1F WM_SETCURSOR = &H20 WM_MOUSEACTIVATE = &H21 WM_CHILDACTIVATE = &H22 WM_QUEUESYNC = &H23 WM_GETMINMAXINFO = &H24 WM_PAINTICON = &H26 WM_ICONERASEBKGND = &H27 WM_NEXTDLGCTL = &H28 WM_SPOOLERSTATUS = &H2A WM_DRAWITEM = &H2B WM_MEASUREITEM = &H2C WM_DELETEITEM = &H2D WM_VKEYTOITEM = &H2E WM_CHARTOITEM = &H2F WM_SETFONT = &H30 WM_GETFONT = &H31 WM_SETHOTKEY = &H32 WM_GETHOTKEY = &H33 WM_QUERYDRAGICON = &H37 WM_COMPAREITEM = &H39 ' #if(WINVER >= 0x0500) WM_GETOBJECT = &H3D ' #endif /* WINVER >= 0x0500 */ WM_COMPACTING = &H41 WM_WINDOWPOSCHANGING = &H46 WM_WINDOWPOSCHANGED = &H47 WM_POWER = &H48 WM_COPYDATA = &H4A WM_CANCELJOURNAL = &H4B ' #if(WINVER >= 0x0400) WM_NOTIFY = &H4E WM_INPUTLANGCHANGEREQUEST = &H50 WM_INPUTLANGCHANGE = &H51 WM_TCARD = &H52 WM_HELP = &H53 WM_USERCHANGED = &H54 WM_NOTIFYFORMAT = &H55 ' '#define NFR_ANSI 1 '#define NFR_UNICODE 2 '#define NF_QUERY 3 '#define NF_REQUERY 4 ' WM_CONTEXTMENU = &H7B WM_STYLECHANGING = &H7C WM_STYLECHANGED = &H7D WM_DISPLAYCHANGE = &H7E WM_GETICON = &H7F WM_SETICON = &H80 ' #endif /* WINVER >= 0x0400 */ ' WM_NCCREATE = &H81 WM_NCDESTROY = &H82 WM_NCCALCSIZE = &H83 WM_NCHITTEST = &H84 WM_NCPAINT = &H85 WM_NCACTIVATE = &H86 WM_GETDLGCODE = &H87 WM_NCMOUSEMOVE = &HA0 WM_NCLBUTTONDOWN = &HA1 WM_NCLBUTTONUP = &HA2 WM_NCLBUTTONDBLCLK = &HA3 WM_NCRBUTTONDOWN = &HA4 WM_NCRBUTTONUP = &HA5 WM_NCRBUTTONDBLCLK = &HA6 WM_NCMBUTTONDOWN = &HA7 WM_NCMBUTTONUP = &HA8 WM_NCMBUTTONDBLCLK = &HA9 ' 'WM_KEYFIRST = &H100 WM_KEYDOWN = &H100 WM_KEYUP = &H101 WM_CHAR = &H102 WM_DEADCHAR = &H103 WM_SYSKEYDOWN = &H104 WM_SYSKEYUP = &H105 WM_SYSCHAR = &H106 WM_SYSDEADCHAR = &H107 'WM_KEYLAST = &H108 ' ' #if(WINVER >= 0x0400) WM_IME_STARTCOMPOSITION = &H10D WM_IME_ENDCOMPOSITION = &H10E WM_IME_COMPOSITION = &H10F 'WM_IME_KEYLAST = &H10F ' #endif /* WINVER >= 0x0400 */ ' WM_INITDIALOG = &H110 WM_COMMAND = &H111 WM_SYSCOMMAND = &H112 WM_TIMER = &H113 WM_HSCROLL = &H114 WM_VSCROLL = &H115 WM_INITMENU = &H116 WM_INITMENUPOPUP = &H117 WM_MENUSELECT = &H11F WM_MENUCHAR = &H120 WM_ENTERIDLE = &H121 ' ' #if(WINVER >= 0x0500) WM_MENURBUTTONUP = &H122 WM_MENUDRAG = &H123 WM_MENUGETOBJECT = &H124 WM_UNINITMENUPOPUP = &H125 WM_MENUCOMMAND = &H126 ' #endif /* WINVER >= 0x0500 */ ' WM_CTLCOLORMSGBOX = &H132 WM_CTLCOLOREDIT = &H133 WM_CTLCOLORLISTBOX = &H134 WM_CTLCOLORBTN = &H135 WM_CTLCOLORDLG = &H136 WM_CTLCOLORSCROLLBAR = &H137 WM_CTLCOLORSTATIC = &H138 'WM_MOUSEFIRST = &H200 WM_MOUSEMOVE = &H200 WM_LBUTTONDOWN = &H201 WM_LBUTTONUP = &H202 WM_LBUTTONDBLCLK = &H203 WM_RBUTTONDOWN = &H204 WM_RBUTTONUP = &H205 WM_RBUTTONDBLCLK = &H206 WM_MBUTTONDOWN = &H207 WM_MBUTTONUP = &H208 WM_MBUTTONDBLCLK = &H209 ' #if (_WIN32_WINNT >= 0x0400) || (_WIN32_WINDOWS > 0x0400) WM_MOUSEWHEEL = &H20A 'WM_MOUSELAST = &H20A ' #else 'WM_MOUSELAST = &H209 ' #endif /* if (_WIN32_WINNT < 0x0400) */ WM_PARENTNOTIFY = &H210 WM_ENTERMENULOOP = &H211 WM_EXITMENULOOP = &H212 ' #if(WINVER >= 0x0400) WM_NEXTMENU = &H213 WM_SIZING = &H214 WM_CAPTURECHANGED = &H215 WM_MOVING = &H216 WM_POWERBROADCAST = &H218 WM_DEVICECHANGE = &H219 ' #endif /* WINVER >= 0x0400 */ WM_MDICREATE = &H220 WM_MDIDESTROY = &H221 WM_MDIACTIVATE = &H222 WM_MDIRESTORE = &H223 WM_MDINEXT = &H224 WM_MDIMAXIMIZE = &H225 WM_MDITILE = &H226 WM_MDICASCADE = &H227 WM_MDIICONARRANGE = &H228 WM_MDIGETACTIVE = &H229 WM_MDISETMENU = &H230 WM_DROPFILES = &H233 WM_MDIREFRESHMENU = &H234 ' #if(WINVER >= 0x0400) WM_IME_SETCONTEXT = &H281 WM_IME_NOTIFY = &H282 WM_IME_CONTROL = &H283 WM_IME_COMPOSITIONFULL = &H284 WM_IME_SELECT = &H285 WM_IME_CHAR = &H286 ' #endif /* WINVER >= 0x0400 */ ' #if(WINVER >= 0x0500) WM_IME_REQUEST = &H288 ' #endif /* WINVER >= 0x0500 */ ' #if(WINVER >= 0x0400) WM_IME_KEYDOWN = &H290 WM_IME_KEYUP = &H291 ' #endif /* WINVER >= 0x0400 */ ' ' #if(_WIN32_WINNT >= 0x0400) WM_MOUSEHOVER = &H2A1 WM_MOUSELEAVE = &H2A3 ' #endif /* _WIN32_WINNT >= 0x0400 */ WM_CUT = &H300 WM_COPY = &H301 WM_PASTE = &H302 WM_CLEAR = &H303 WM_UNDO = &H304 WM_RENDERFORMAT = &H305 WM_RENDERALLFORMATS = &H306 WM_DESTROYCLIPBOARD = &H307 WM_DRAWCLIPBOARD = &H308 WM_PAINTCLIPBOARD = &H309 WM_VSCROLLCLIPBOARD = &H30A WM_SIZECLIPBOARD = &H30B WM_ASKCBFORMATNAME = &H30C WM_CHANGECBCHAIN = &H30D WM_HSCROLLCLIPBOARD = &H30E WM_QUERYNEWPALETTE = &H30F WM_PALETTEISCHANGING = &H310 WM_PALETTECHANGED = &H311 WM_HOTKEY = &H312 ' ' #if(WINVER >= 0x0400) WM_PRINT = &H317 WM_PRINTCLIENT = &H318 ' WM_HANDHELDFIRST = &H358 WM_HANDHELDLAST = &H35F ' WM_AFXFIRST = &H360 WM_AFXLAST = &H37F ' #endif /* WINVER >= 0x0400 */ ' WM_PENWINFIRST = &H380 WM_PENWINLAST = &H38F ' ' #if(WINVER >= 0x0400) WM_APP = &H8000 ' #endif /* WINVER >= 0x0400 */ ' NOTE: All Message Numbers below 0x0400 are RESERVED. ' Private Window Messages Start Here: WM_USER = &H400 End Enum Public Enum eWSCHitTest ' WM_NCHITTEST and MOUSEHOOKSTRUCT Mouse Position Codes HTERROR = (-2) HTTRANSPARENT = (-1) HTNOWHERE = 0 HTCLIENT = 1 HTCAPTION = 2 HTSYSMENU = 3 HTGROWBOX = 4 HTSIZE = HTGROWBOX HTMENU = 5 HTHSCROLL = 6 HTVSCROLL = 7 HTMINBUTTON = 8 HTMAXBUTTON = 9 HTLEFT = 10 HTRIGHT = 11 HTTOP = 12 HTTOPLEFT = 13 HTTOPRIGHT = 14 HTBOTTOM = 15 HTBOTTOMLEFT = 16 HTBOTTOMRIGHT = 17 HTBORDER = 18 HTREDUCE = HTMINBUTTON HTZOOM = HTMAXBUTTON HTSIZEFIRST = HTLEFT HTSIZELAST = HTBOTTOMRIGHT End Enum Public Enum eWSCMF ' Menú Flags para WM_MENUSELECT 'MF_UNCHECKED = &H0& MF_GRAYED = &H1& MF_DISABLED = &H2& MF_BITMAP = &H4& MF_CHECKED = &H8& MF_POPUP = &H10& MF_HILITE = &H80& MF_OWNERDRAW = &H100& MF_SYSMENU = &H2000& MF_MOUSESELECT = &H8000& End Enum ' Valores de fuSource para el mensaje WM_ENTERIDLE Public Enum eWSCMSFG MSGF_DIALOGBOX = 0 MSGF_MENU = 2 End Enum ' Mensajes varios Public Enum eWSCMisc ' WM_ACTIVATE state values WA_INACTIVE = 0 WA_ACTIVE = 1 WA_CLICKACTIVE = 2 ' wParam for WM_POWER window message and DRV_POWER driver notification PWR_OK = 1 PWR_FAIL = (-1) PWR_SUSPENDREQUEST = 1 PWR_SUSPENDRESUME = 2 PWR_CRITICALRESUME = 3 ' WM_SYNCTASK Commands ST_BEGINSWP = 0 ST_ENDSWP = 1 ' SendMessageTimeout values SMTO_NORMAL = &H0 SMTO_BLOCK = &H1 SMTO_ABORTIFHUNG = &H2 ' WM_MOUSEACTIVATE Return Codes MA_ACTIVATE = 1 MA_ACTIVATEANDEAT = 2 MA_NOACTIVATE = 3 MA_NOACTIVATEANDEAT = 4 ' WM_SIZE message wParam values SIZE_RESTORED = 0 SIZE_MINIMIZED = 1 SIZE_MAXIMIZED = 2 SIZE_MAXSHOW = 3 SIZE_MAXHIDE = 4 ' WM_NCCALCSIZE return flags WVR_ALIGNTOP = &H10 WVR_ALIGNLEFT = &H20 WVR_ALIGNBOTTOM = &H40 WVR_ALIGNRIGHT = &H80 WVR_HREDRAW = &H100 WVR_VREDRAW = &H200 WVR_REDRAW = (WVR_HREDRAW Or WVR_VREDRAW) WVR_VALIDRECTS = &H400 ' Key State Masks for Mouse Messages MK_LBUTTON = &H1 MK_RBUTTON = &H2 MK_SHIFT = &H4 MK_CONTROL = &H8 MK_MBUTTON = &H10 ' Constantes para el menú del sistema SC_RESTORE = &HF120& SC_MOVE = &HF010& SC_SIZE = &HF000& SC_MINIMIZE = &HF020& SC_MAXIMIZE = &HF030& SC_CLOSE = &HF060& ' Track Mouse Event HOVER_DEFAULT = &HFFFFFFFF ' #if(_WIN32_WINNT >= 0x0400) WHEEL_DELTA = 120 ' /* Value for rolling one detent */ ' #endif /* _WIN32_WINNT >= 0x0400 */ ' #if(_WIN32_WINNT >= 0x0400) '#define UINT_MAX =&hffffffff /* maximum unsigned int value */ '#define WHEEL_PAGESCROLL (UINT_MAX) /* Scroll one page */ WHEEL_PAGESCROLL = &HFFFFFFFF ' #endif /* _WIN32_WINNT >= 0x0400 */ '// begin_pbt PBT_APMQUERYSUSPEND = &H0 ' Request for permission to suspend. PBT_APMQUERYSTANDBY = &H1 ' PBT_APMQUERYSUSPENDFAILED = &H2 ' Suspension request denied. PBT_APMQUERYSTANDBYFAILED = &H3 ' PBT_APMSUSPEND = &H4 ' System is suspending operation. PBT_APMSTANDBY = &H5 ' PBT_APMRESUMECRITICAL = &H6 ' Operation resuming after critical suspension. PBT_APMRESUMESUSPEND = &H7 ' Operation resuming after suspension. PBT_APMRESUMESTANDBY = &H8 ' PBTF_APMRESUMEFROMFAILURE = &H1& ' PBT_APMBATTERYLOW = &H9 ' Battery power is low. PBT_APMPOWERSTATUSCHANGE = &HA ' Power status has changed. ' PBT_APMOEMEVENT = &HB ' OEM-defined event occurred. PBT_APMRESUMEAUTOMATIC = &H12 ' Operation resuming automatically after event. '// end_pbt End Enum ' WM_WINDOWPOSCHANGING/CHANGED struct pointed to by lParam Private Type WINDOWPOS hWnd As Long hWndInsertAfter As Long X As Long Y As Long cx As Long cy As Long flags As Long End Type Public Enum eTME ' Track Mouse Event TME_HOVER = &H1 TME_LEAVE = &H2 TME_QUERY = &H40000000 TME_CANCEL = &H80000000 End Enum Private Type tTRACKMOUSEEVENT cbSize As Long dwFlags As eTME 'Long hWndTrack As Long dwHoverTime As Long End Type Private Declare Function TrackMouseEvent Lib "User32" _ (lpEventTrack As tTRACKMOUSEEVENT) As Long 'Private Declare Function DefWindowProc Lib "User32" Alias "DefWindowProcA" _ (ByVal hWnd As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ (Destination As Any, Source As Any, ByVal Length As Long) '------------------------------------------------------------------------------ ' *** Los eventos producidos por la clase *** '------------------------------------------------------------------------------ ' Eventos genéricos, no directamente relacionados con la ventana subclasificada ' Permite interceptar todos los mensajes producidos Public Event MSG(ByVal uMSG As eWSCWM, ByVal wParam As Long, ByVal lParam As Long) ' Indica el menú seleccionado Public Event MenuSelected(ByVal mnuItem As Long, mnuFlags As eWSCMF, ByVal hMenu As Long) ' Ha cambiado el tamaño del objeto Screen y/o el número de colores Public Event DisplayChange(ByVal BitsPerPixel As Long, ByVal cxScreen As Long, ByVal cyScreen As Long) ' Se ha añadido o quitado alguna fuente del sistema Public Event FontChange() ' El sistema indica que hay pocos recursos disponibles Public Event LowMemory() ' Este evento se producirá mientras se está seleccionando un menú o en un diálogo ' dentro del formulario 'Public Event EnterIDLE(ByVal IsIDLE As Boolean, ByVal fuSource As Long, ByVal hWnd As Long) 'Public Event EnterIDLE(ByVal IsIDLE As Boolean, ByVal fuSource As eWSCMSFG, ByVal hWnd As Long) '------------------------------------------------------------------------------ ' Eventos directamente relacionados con la ventana subclasificada ' La ventana ha cambiado de posición, indica la posición y tamaño Public Event WindowPosChanged(ByVal wLeft As Long, ByVal wTop As Long, ByVal wWidth As Long, ByVal wHeight As Long) ' Se ha movido esta ventana, devuelve la posición en twips Public Event Move(ByVal wLeft As Long, ByVal wTop As Long) ' El ratón sale de la ventana subclasificada Public Event MouseLeave() ' Indica de que control sale, si la ventana contiene otros controles Public Event MouseLeaveOn(unControl As Object) ' El ratón entra en la ventana Public Event MouseEnter() ' Indica en que control entra, si la ventana contiene controles Public Event MouseEnterOn(unControl As Object) ' Indica si se ha movido la rueda del ratón y los parámetros correspondientes Public Event MouseWheel(ByVal wKeys As Long, ByVal zDelta As Long, ByVal xPos As Long, ByVal yPos As Long) ' Public Event SetCursor(unControl As Object, ByVal HitTest As eWSCHitTest, ByVal MouseMsg As Long) ' Se activa la ventana Public Event Activate() ' Se desactiva la ventana Public Event Deactivate() Private Sub Class_Initialize() ' Esto no es necesario, pero lo uso para saber que cuando se inicia la clase ' estas variables locales están a "cero" mhWnd = 0 mPrevWndProc = 0 '-------------------------------------------------------------------------- ' Para devolver los valores en twips, ' ya que el valor devuelto originalmente será en pixels ' ' Se hace en este evento para no tener que calcularlo en cada mensaje. '$Por hacer: (22/Mar/99) ' Si se cambia la resolución habría que cambiar estos valores... '-------------------------------------------------------------------------- twX = Screen.TwipsPerPixelX twY = Screen.TwipsPerPixelY End Sub Private Sub Class_Terminate() ' Comprobar si están iniciadas las variables ' y de ser así dejar de subclasificar el formulario If mhWnd Then MSubclass.unHook Me End If End Sub Public Sub Hook(Optional ByVal NewValue As Object = Nothing) '-------------------------------------------------------------------------- ' Este método se debe usar para iniciar o terminar la subclasificación ' ' El parámetro se usará para indicar la ventana a subclasificar, ' se podría haber usado un valor Long para el hWnd de la ventana, pero, ' es que este objeto se usa para comprobar los controles incluidos ' ya que en los mensajes procesados se puede procesar si el ratón sale o ' entra en algún control incluido en la colección controls, ' por tanto sólo tiene utilidad real si ese objeto tiene una colección Controls ' (por ejemplo un formulario o un control de usuario) ' ' Nota: Se puede subclasificar un form o cualquier otro control con hWnd '-------------------------------------------------------------------------- On Local Error GoTo ErrHook If NewValue Is Nothing Then ' Quitar el 'gancho' del form If Me.hWnd <> 0 Then MSubclass.unHook Me End If ' Si no tiene hWnd producirá error ElseIf NewValue.hWnd = 0 Then ' Else ' Si ya había una copia funcionando, quitar el gancho (08/Ago/99) If Me.hWnd <> 0 Then MSubclass.unHook Me End If ' Asignar el nuevo gancho a la ventana a subclasificar MSubclass.Hook Me, NewValue Set mWndType = NewValue End If Exit Sub ErrHook: ' Nada que hacer si se pasa un parámero erróneo. ' Devolver un error indicándolo On Local Error GoTo 0 With Err .Description = "El parámetro debe ser una ventana (que tenga la propiedad hWnd) " & _ "o Nothing para dejar de interceptar los mensajes." & _ vbCrLf & vbCrLf & _ "El tipo del parámetro es: " & TypeName(NewValue) .Source = "cSubclass.Hook" .Raise .Number End With End Sub Friend Sub unMSG(ByVal uMSG As eWSCWM, ByVal wParam As Long, ByVal lParam As Long) ' Este procedimiento será el que reciba los mensajes y se encargará ' de producir los eventos correspondientes ' Usar variables estáticas para mayor rapidez Static tWP As WINDOWPOS Static bMouseEnter As Boolean Static ControlAnt As Control ' Control en el que se produjo el MouseMove ' para los casos en los que la ventana ' subclasificada tenga otros controles ' Si se produce un error que no se pare la aplicación... On Local Error Resume Next '------------------------------------------------------------------------------ ' Si está en modo IDLE (no hay mensajes) 'If uMSG = WM_ENTERIDLE Then ' '-------------------------------------------------------------------------- ' ' Se ha entrado en un estado en el que no hay mensajes ' ' ' ' ' fuSource = wParam; // idle-source flag ' ' hwnd = (HWND) lParam; // handle of dialog box or owner window ' ' ' ' Value of wParam. Specifies whether the message is the result of a dialog box ' ' or a menu being displayed. ' ' This parameter can be one of the following values: ' ' MSGF_DIALOGBOX The system is idle because a dialog box is displayed. ' ' MSGF_MENU The system is idle because a menu is displayed. ' ' ' RaiseEvent EnterIDLE(True, wParam, lParam) ' ' ''------------------------------------------------------------------------------ '' Hay otros mensajes aparte del IDLE 'Else ' '-------------------------------------------------------------------------- ' ' Indicar que ya no está en modo IDLE ' RaiseEvent EnterIDLE(False, 0&, 0&) '-------------------------------------------------------------------------- ' Evento genérico RaiseEvent MSG(uMSG, wParam, lParam) ' Según el tipo de mensaje, producir eventos... Select Case uMSG '-------------------------------------------------------------------------- ' Selección de un menú Case WM_MENUSELECT ' Los parámetros son: mnuItem mnuFlags mnuHandle RaiseEvent MenuSelected(LoWord(wParam), HiWord(wParam), lParam) '-------------------------------------------------------------------------- ' Cambio en la posición y tamaño de la ventana ' La posición y tamaño se indicará en twips Case WM_WINDOWPOSCHANGED 'WM_WINDOWPOSCHANGING '---------------------------------------------------------------------- ' Nota: Los valores de twX y twY se asignan en el evento Initialize '-------------------------------------------------------------------------- ' Copiar el valor referenciado por lParam en un UDT CopyMemory tWP, ByVal lParam, Len(tWP) With tWP ' Left Top Width Height RaiseEvent WindowPosChanged(.X * twX, .Y * twY, .cx * twX, .cy * twY) End With '-------------------------------------------------------------------------- ' Se ha movido la ventana ' La posición se indicará en twips Case WM_MOVE With tWP .X = LoWord(lParam) .Y = HiWord(lParam) RaiseEvent Move(.X * twX, .Y * twY) End With '-------------------------------------------------------------------------- ' Ha cambiado la resolución de la pantalla o el número de colores Case WM_DISPLAYCHANGE ' BitsPerPixels ' New horizontal resolution of the screen ' New vertical resolution of the screen RaiseEvent DisplayChange(wParam, LoWord(lParam), HiWord(lParam)) '-------------------------------------------------------------------------- ' Se han añadido o quitado fuentes del sistema Case WM_FONTCHANGE RaiseEvent FontChange '-------------------------------------------------------------------------- ' El sistema está compactando la memoria porque tiene poca disponible Case WM_COMPACTING RaiseEvent LowMemory '-------------------------------------------------------------------------- ' The WM_ACTIVATEAPP message is sent when a window belonging to a different ' application than the active window is about to be activated. ' The message is sent to the application whose window is being activated ' and to the application whose window is being deactivated. ' fActive = (BOOL) wParam; // activation flag ' ' Specifies whether the window is being activated or deactivated. ' This parameter is TRUE if the window is being activated; ' it is FALSE if the window is being deactivated. ' ' Si se activa o desactiva la ventana Case WM_ACTIVATEAPP If wParam Then RaiseEvent Activate Else RaiseEvent Deactivate End If '-------------------------------------------------------------------------- ' Si se ha movido la rueda de los ratos con ruedas Case WM_MOUSEWHEEL 'fwKeys = LOWORD(wParam); // key flags 'zDelta = (short) HIWORD(wParam); // wheel rotation 'xPos = (short) LOWORD(lParam); // horizontal position of pointer 'yPos = (short) HIWORD(lParam); // vertical position of pointer RaiseEvent MouseWheel(LoWord(wParam), HiWord(wParam), LoWord(lParam), HiWord(lParam)) ' ' fwKeys: ' Indicates whether various virtual keys are down. ' This parameter can be any combination of the following values: ' (estos valores están en la enumeración: eWSCMisc) ' MK_CONTROL Set if the ctrl key is down. ' MK_LBUTTON Set if the left mouse button is down. ' MK_MBUTTON Set if the middle mouse button is down. ' MK_RBUTTON Set if the right mouse button is down. ' MK_SHIFT Set if the shift key is down. ' ' zDelta: ' Indicates the distance that the wheel is rotated, ' expressed in multiples or divisions of WHEEL_DELTA, which is 120. ' A positive value indicates that the wheel was rotated forward, ' away from the user; ' a negative value indicates that the wheel was rotated backward, ' toward the user. '-------------------------------------------------------------------------- ' Cuando el ratón sale del área de la ventana indicada Case WM_MOUSELEAVE ' Si este mensaje se intercepta en un control incluido en el form ' además del propio form, cuando se entre en un control se producirá ' un MouseLeave en el form (y viceversa) RaiseEvent MouseLeave bMouseEnter = False '-------------------------------------------------------------------------- ' Cuando el ratón se mueve, es porque está en la ventana, ' comprobar si es la primera vez que entra y así lanzar el evento MouseEnter Case WM_MOUSEMOVE ' Cuando se produce un MouseMove, es decir que el mouse está en el control ' hay que indicar que se vuelva a detectar la salida del control If Not bMouseEnter Then bMouseEnter = True With mtTME .dwFlags = TME_LEAVE .cbSize = Len(mtTME) .hWndTrack = mhWnd End With Call TrackMouseEvent(mtTME) ' RaiseEvent MouseEnter ' ' Comprobar si está asignado el control anterior If Not (ControlAnt Is Nothing) Then RaiseEvent MouseLeaveOn(ControlAnt) End If End If '-------------------------------------------------------------------------- ' The WM_SETCURSOR message is sent to a window if the mouse causes the cursor ' to move within a window and mouse input is not captured. ' Parámetros: ' hwnd = (HWND) wParam; // handle to window with cursor ' nHittest = LOWORD(lParam); // hit-test code ' wMouseMsg = HIWORD(lParam); // mouse-message identifier Case WM_SETCURSOR Dim i As Long Dim tControl As Control Dim nHittest As Long Dim wMouseMsg As Long nHittest = LoWord(lParam) wMouseMsg = HiWord(lParam) ' Este bucle sólo funcionará si la ventana subclasificada ' tiene una colección de controles, (por ejemplo un form) For Each tControl In mWndType.Controls With tControl ' Si no es este control o el control no soporta el hWnd If .hWnd <> wParam Then ' Else RaiseEvent SetCursor(tControl, nHittest, wMouseMsg) ' Si el mensaje del ratón es que se mueve... If wMouseMsg = WM_MOUSEMOVE Then ' Comprobar si ya había entrado en el control If ControlAnt.hWnd <> wParam Then ' Si ya se había asignado If Not (ControlAnt Is Nothing) Then ' Se ha salido de este control RaiseEvent MouseLeaveOn(ControlAnt) End If End If ' Asignar este control para posteriores comprobaciones Set ControlAnt = tControl RaiseEvent MouseEnterOn(tControl) End If Exit For End If End With Next End Select ' ' 'End If End Sub Friend Property Get hWnd() As Long hWnd = mhWnd End Property Friend Property Let hWnd(ByVal NewValue As Long) mhWnd = NewValue End Property Friend Property Get PrevWndProc() As Long PrevWndProc = mPrevWndProc End Property Friend Property Let PrevWndProc(ByVal NewValue As Long) mPrevWndProc = NewValue End Property Private Function LoWord(ByVal Numero As Long) As Long ' Devuelve el LoWord del número pasado como parámetro LoWord = Numero And &HFFFF& End Function Private Function HiWord(ByVal Numero As Long) As Long ' Devuelve el HiWord del número pasado como parámetro HiWord = Numero \ &H10000 And &HFFFF& End Function
Volver a Visual Basic Avanzado