Rubrik: Controls · Sonstiges | VB-Versionen: VB5, VB6 | 09.03.05 |
"MouseInOut (GES)" für Controls MIT und OHNE hWnd Mit diesem Tipp spendieren Sie allen Controls ein MouseIn bzw. MouseOut-Ereignis. | ||
Autor: Guido Eisenbeis | Bewertung: | Views: 20.088 |
ohne Homepage | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
Um Aktionen ausführen zu lassen, wenn die Maus ein Control überfährt, benötigt man bekannterweise eine Art MouseIn-/MouseOut-Ereignis. Leider besitzen die VB-Standard-Controls diese Ereignisse nicht, so dass wir uns wieder einmal selbst behelfen müssen.
In der jeweiligen Form werden "Pseudo-Ereignisse" ("MouseIn" und "MouseOut") angelegt. Diese können dann genauso wie "normale" Ereignisse (z.B. Click) aufgerufen werden.
Das Besondere an "MouseInOut (GES)" ist, dass das Control kein hWnd besitzen muss (z.B. Label und Image). Geprüft wird die Maus-Position und ein Comparing-hWnd.
Berücksichtigt wird auch, ob sich ein Control in anderen Controls (Container) befindet. Diese MouseInOut-Überwachung funktioniert sehr präzise. Im Gegensatz zu Codes mit "SetCapture, ReleaseCapture" gibt es hier kein "Hängenbleiben"!
Bereits vor einem knappen Jahr haben wir in unserem Extra-Tipps Bereich einen entsprechenden Code vorgestellt.
Dieser Tipp wurde jetzt nochmals überarbeitet und verbessert.
- Code überarbeitet und verfeinert: Er ist effektiver und übersichtlicher
- Die Form, die das Control enthält, wird automatisch ermittelt (d. h. der Aufruf ist einfacher)
- "MouseInOut (GES)" wird beendet, wenn die Form den Fokus verliert (inaktiv wird).
- "MouseInOut (GES)" bemerkt, falls das überwachte Control von einer inaktiven "OnTop"-Form oder "OnTop"-MsgBox teilweise verdeckt wird.
Fügen Sie Ihrem Projekt ein neues Modul hinzu und kopieren nachfolgenden Code in das Modul:
Option Explicit ' Benötigte API-Deklarationen Private Declare Function SetTimer Lib "user32.dll" ( _ ByVal hwnd As Long, _ ByVal nIDEvent As Long, _ ByVal uElapse As Long, _ ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32.dll" ( _ ByVal hwnd As Long, _ ByVal nIDEvent As Long) As Long Public lEvent As Long ' Timer-ID Private Declare Function GetCursorPos Lib "user32" ( _ lpPoint As POINTAPI) As Long Private Declare Function ClientToScreen Lib "user32" ( _ ByVal hwnd As Long, _ lpPoint As POINTAPI) As Long Private Declare Function GetWindowRect Lib "user32" ( _ ByVal hwnd As Long, _ lpRect As RECT) As Long Private Declare Function PtInRect Lib "user32" ( _ lpRect As RECT, _ ByVal X As Long, _ ByVal Y As Long) As Long Private Declare Function WindowFromPoint Lib "user32" ( _ ByVal xPoint As Long, _ ByVal yPoint As Long) As Long Private Declare Function GetForegroundWindow Lib "user32" () As Long Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type POINTAPI X As Long Y As Long End Type Private fForm As Form ' Wird für "CallByName" benötigt Private Ctrl As Control ' Ist das zu überwachende Control Private CtrlRect As RECT ' Ist das Control-Rechteck (die Fläche) Private CompHWND As Long ' hWnd, das zum Überwachen benutzt wird Private M_Enter As Boolean ' Indikator für "MouseIn" Public CtrlIndex As Integer ' Falls es sich um ein Steuerelementefeld handelt, ' kann im "Pseudo-Ereignis" der Form der jeweilige ' Index über "CtrlIndex" verwendet werden. ' (Beispiel siehe ganz unten.)
' Starten der MouseInOut-Überwachung Public Sub MouseInOutTracking(ByVal cControl As Control) Dim Ret As Long ' für verschiedene Rückgabewerte Dim TmpCtrl As Object ' zum Ermitteln der (Parent-)Form Dim Cont As Object ' Container des jeweiligen Controls Dim ContRect As RECT ' Container-Rechteck (Fläche) Dim P1 As POINTAPI ' Begrenzungs-Punkte ... Dim P2 As POINTAPI ' ... des Control-Rechtecks ' MouseOut auslösen, falls das im MouseMove übergebene ' Control nicht das überwachte Control ist. ' (Sehr wichtig, falls 2 überwachte Controls sehr dicht ' beieinander, oder ineinander (Container) liegen, oder ' sich überlappen.) If ((Not Ctrl Is cControl)) Then ' MouseOut nur auslösen, falls der Timer schon läuft If (lEvent <> 0) Then ' ************ Maus hat das Control verlassen ************ DisableTimer M_Enter = False ' MouseOut-Routine aufrufen Call DoByMouseOut ' ******************************************************** End If ' Die (Parent-)Form des übergebenen Controls ermitteln Set TmpCtrl = cControl Do ' Solange den nächsthöheren Container prüfen, ' bis die Form gefunden ist. Set TmpCtrl = TmpCtrl.Container If (TypeOf TmpCtrl Is Form) Then Set fForm = TmpCtrl ' Übergabe an Modul-weit gültige Variable Set TmpCtrl = Nothing ' Speicher freigeben Exit Do End If Loop Set Ctrl = cControl ' Übergabe an Modul-weit gültige Variable End If ' MouseInOut-Überwachung nur dann starten: ' - falls die Überwachung noch nicht gestartet ist ' - und falls die Form aktiv ist ' (verhindert das Flackern von Controls (Labels)) If ((lEvent = 0) And (fForm.hwnd = GetForegroundWindow)) Then On Error Resume Next ' Fehlerbehandlung für Prüfungen ausschalten ' Index zuweisen, falls es sich um ein Steuerelementefeld handelt CtrlIndex = Ctrl.Index CompHWND = 0 ' zurücksetzen! CompHWND = Ctrl.hwnd ' Wegen "On Error ..."-Prüfung gesondert zuweisen If (CompHWND <> 0) Then ' Control besitzt ein HWND Ret = 0 ' zurücksetzen! Ret = Ctrl.ScaleMode ' Prüfen auf VB-konformen ScaleMode ' (nur Controls mit ScaleMode 1 bis 7 werden unterstützt!) On Error GoTo 0 ' Fehlerbehandlung wieder ausschalten ' Begrenzungs-Punkte des Control-Rechtecks ermitteln If (Ret > 0) Then ' Nur "Innen-Fläche" (Form, PictureBox) berücksichtigen ' (wo auch MouseMove beginnt). Emöglicht grosse Genauigkeit. P1.X = 0 P1.Y = 0 P2.X = Ctrl.ScaleX(Ctrl.ScaleWidth, Ctrl.ScaleMode, vbPixels) P2.Y = Ctrl.ScaleY(Ctrl.ScaleHeight, Ctrl.ScaleMode, vbPixels) Call ClientToScreen(Ctrl.hwnd, P1) Call ClientToScreen(Ctrl.hwnd, P2) Else Call GetWindowRect(Ctrl.hwnd, CtrlRect) P1.X = CtrlRect.Left P1.Y = CtrlRect.Top P2.X = CtrlRect.Right P2.Y = CtrlRect.Bottom End If Else ' Control ohne HWND ' Eine Prüfung per "WindowFromPoint" gibt bei einem ' Control ohne hWnd das hWnd des Containers zurück. ' Deshalb das Container-hWnd für Überprüfung zuweisen. CompHWND = Ctrl.Container.hwnd Set Cont = Ctrl.Container ' Container-Rechteck ermitteln Call GetWindowRect(Cont.hwnd, ContRect) Ret = 0 ' zurücksetzen! Ret = Cont.ScaleMode ' Prüfen auf VB-konformen ScaleMode ' (nur Container mit ScaleMode 1 bis 7 werden unterstützt!) ' Begrenzungs-Punkte des Control-Rechtecks ermitteln If (Ret > 0) Then ' (Form, PictureBox, ... mit ScaleMode ab 1) P1.X = Cont.ScaleX(Ctrl.Left, Cont.ScaleMode, vbPixels) P1.Y = Cont.ScaleY(Ctrl.Top, Cont.ScaleMode, vbPixels) P2.X = P1.X + Cont.ScaleX(Ctrl.Width, Cont.ScaleMode, vbPixels) P2.Y = P1.Y + Cont.ScaleY(Ctrl.Height, Cont.ScaleMode, vbPixels) Call ClientToScreen(Cont.hwnd, P1) Call ClientToScreen(Cont.hwnd, P2) Else ' (Frame, ... immer mit Twips) P1.X = ContRect.Left + (Ctrl.Left / Screen.TwipsPerPixelX) P1.Y = ContRect.Top + (Ctrl.Top / Screen.TwipsPerPixelY) P2.X = P1.X + (Ctrl.Width / Screen.TwipsPerPixelX) P2.Y = P1.Y + (Ctrl.Height / Screen.TwipsPerPixelY) End If End If ' Die Punkte dem Control-Rechteck zuweisen CtrlRect.Left = P1.X CtrlRect.Top = P1.Y CtrlRect.Right = P2.X CtrlRect.Bottom = P2.Y ' Timer starten (Interval-Angabe in Millisekunden) Call EnableTimer(50) End If End Sub
' Startet den Timer für die MouseInOut-Überwachung Private Sub EnableTimer(ByVal msInterval As Long) If (lEvent = 0) Then lEvent = SetTimer(fForm.hwnd, 44, msInterval, AddressOf TimerProc) End If End Sub
' Timer-Prozedur: löst im Abstand der festgelegten ' Millisekunden die Aktionen für die MouseInOut-States aus. Private Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) Dim CP As POINTAPI If (M_Enter = False) Then ' ************* Maus tritt in das Control ein ************ M_Enter = True ' MouseIn-Routine aufrufen Call DoByMouseIn End If ' Cursor-Position ermitteln Call GetCursorPos(CP) ' - Ist der Cursor innerhalb des Control-Rechtecks? ' - Ist die Form aktiv? ' - Ist das Control von einer inaktiven "OnTop"-Form ' oder "OnTop"-MsgBox teilweise verdeckt? If (PtInRect(CtrlRect, CP.X, CP.Y) _ And (fForm.hwnd = GetForegroundWindow) _ And (WindowFromPoint(CP.X, CP.Y) = CompHWND)) Then ' ************** Maus ist über dem Control *************** ' MouseOver-Routine aufrufen (optional) ' Call DoByMouseOver Else ' ************ Maus hat das Control verlassen ************ DisableTimer M_Enter = False ' MouseOut-Routine aufrufen Call DoByMouseOut End If End Sub
' Beendet den Timer für die MouseInOut-Überwachung Public Sub DisableTimer() If (lEvent <> 0) Then KillTimer fForm.hwnd, lEvent lEvent = 0 End If End Sub
' Auszuführende Aktionen für Maus-Eintritt ("MouseIn") Private Sub DoByMouseIn() On Error Resume Next ' "Pseudo-Ereignis" in der Form aufrufen ' * Wichtige Hinweise für "CallByName" siehe unten! Call CallByName(fForm, Ctrl.Name & "_MouseIn", VbMethod) End Sub
' Auszuführende Aktionen für Maus-Austritt ("MouseOut") Private Sub DoByMouseOut() On Error Resume Next ' "Pseudo-Ereignis" in der Form aufrufen ' * Wichtige Hinweise für "CallByName" siehe unten! Call CallByName(fForm, Ctrl.Name & "_MouseOut", VbMethod) CtrlIndex = -1 'Index als uniniziiert markieren (Optional) End Sub
Wichtige Hinweise für "CallByName"
Um direkt in der Form ein "Pseudo-Ereignis" aufrufen zu können, muss dies erst (von Hand) erstellt werden. Man deklariert dort eine !!ÖFFENTLICHE!! (PUBLIC) Prozedur (Ereignis), die exakt mit dem aufrufenden "CallByName"-String in "MouseInOut (GES)" übereinstimmt!
Ein solches "Pseudo-Ereignis" besteht aus dem Namen des zu überwachenden Controls (z. B. Label1), plus einem Unterstrich, plus entweder MouseIn oder MouseOut.
Beispiele für die Anwendung
Beispiel 1 (Label):
' MouseInOut-Überwachung starten Private Sub Label1_MouseMove(Button As Integer, _ Shift As Integer, X As Single, Y As Single) Call MouseInOutTracking(Label1) End Sub
' "Pseudo-Ereignise" ' Maus-Eintritt Public Sub Label1_MouseIn() Label1.ForeColor = vbRed Me.Caption = "Maus befindet sich über Label1" End Sub ' Maus-Austritt Public Sub Label1_MouseOut() Label1.ForeColor = vbBlack Me.Caption = "Außerhalb" End Sub
Beispiel 2 (Label-Steuerelementfeld):
' MouseInOut-Überwachung starten Private Sub Label1_MouseMove(Index As Integer, Button As Integer, _ Shift As Integer, X As Single, Y As Single) Call MouseInOutTracking(Label1(Index)) End Sub
' "Pseudo-Ereignise" ' Maus-Eintritt Public Sub Label1_MouseIn() Label1(CtrlIndex).ForeColor = vbRed Me.Caption = "Maus befindet sich über Label1(" & CtrlIndex & ")" End Sub
' Maus-Austritt Public Sub Label1_MouseOut() Label1(CtrlIndex).ForeColor = vbBlack Me.Caption = "Außerhalb" End Sub