Um Aktionen ausführen lassen, wenn die Mouse 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. Das Besondere an diesem Code ist, dass das Control kein hWnd besitzen muss (z.B. Label und Image). Geprüft wird die Maus-Position. Diese MouseInOut-Überwachung funktioniert sehr präzise. In der aufrufenden Form können die "Pseudo-Ereignisse" "MouseIn","MouseOver" und "MouseOut" genauso wie "normale" Ereignisse (z.B. Click) aufgerufen werden. Der Aufruf erfolgt im MouseMove des jeweiligen Controls. 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 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 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 M_Enter As Boolean ' Indikator für "MouseIn" ' Starten der MouseOver-Überwachung Public Sub PrüfeMouseOver(ByVal Form As Form, ByVal cControl As Control) Dim Ret As Long Dim Cont As Object ' Container des jeweiligen Controls Dim ContRect As RECT ' Container-Recheck (Fläche) Dim P1 As POINTAPI ' Begrenzungs-Punkte ... Dim P2 As POINTAPI ' ... des Control-Rechtecks On Error Resume Next If Not Ctrl Is Nothing Then ' Falls 2 überwachte Controls sehr dicht ' beieinander liegen oder sich sogar überlappen If Not cControl.Container Is Ctrl.Container _ Or Not cControl.Left = Ctrl.Left _ Or Not cControl.Width = Ctrl.Width _ Or Not cControl.Top = Ctrl.Top _ Or Not cControl.Height = Ctrl.Height Then ' Mouse hat das Control verlassen M_Enter = False DisableTimer ' MouseOut-Routine aufrufen Call DoByMouseOut End If End If Set fForm = Form Set Ctrl = cControl If M_Enter = False Then Ret = 0 ' zurücksetzen! Ret = Ctrl.hwnd ' Wegen "On Error ..."-Prüfung gesondert zuweisen If Ret <> 0 Then ' Control besitzt ein HWND Ret = 0 ' zurücksetzen! Ret = Ctrl.ScaleMode ' Prüfen auf VB-konformen ScaleMode ' Begrenzungs-Punkte des Control-Rechtecks ermitteln If Ret > 0 Then ' Nur "Innen-Fläche" (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 ' (nur Container mit VB-konformen ScaleMode werden unterstützt!) 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 ' 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, ...) 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 MouseOver-Überwachung Private Sub EnableTimer(ByVal msInterval As Long) If lEvent = 0 Then lEvent = SetTimer(fForm.hwnd, 44, msInterval, AddressOf TimerProc) End If End Sub ' Die Timer-Prozedur löst im Abstand der festgelegten ' Millisekunden die Aktionen für die MouseOver-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 On Error Resume Next 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? If PtInRect(CtrlRect, CP.X, CP.Y) Then ' *** Maus ist über dem Control *** ' MouseOver-Routine aufrufen Call DoByMouseOver Else ' *** Maus hat das Control verlassen *** M_Enter = False DisableTimer ' MouseOut-Routine aufrufen Call DoByMouseOut End If End Sub ' Beendet den Timer für die MouseOver-Ü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 ' Entweder Aktion für Maus-Eintritt hier einsetzen, oder ... Beep ' ... direkt in der Form ein "Pseudo-Ereignis" aufrufen ' * Wichtiger Hinweis siehe Anmerkung am Ende des Tipps! Call CallByName(fForm, Ctrl.Name & "_MouseIn", VbMethod) End Sub ' Auszuführende Aktionen für Maus-Drüber ("MouseOver") Private Sub DoByMouseOver() Dim Indx As String On Error Resume Next ' Entweder Aktion für Maus-Drüber hier einsetzen, oder ... Ctrl.ForeColor = vbRed Form1.Label1.ForeColor = vbRed Indx = " (" & Ctrl.Index & ")" Form1.Label1.Caption = "Maus befindet sich über " & Ctrl.Name & Indx ' ... direkt in der Form ein "Pseudo-Ereignis" aufrufen ' * Wichtiger Hinweis siehe Anmerkung am Ende des Tipps! Call CallByName(fForm, Ctrl.Name & "_MouseOver", VbMethod) End Sub ' Auszuführende Aktionen für Maus-Austritt ("MouseOut") Private Sub DoByMouseOut() On Error Resume Next ' Entweder Aktion für Maus-Austritt hier einsetzen, oder ... Ctrl.ForeColor = vbBlack Form1.Label1.ForeColor = vbBlue Form1.Label1.Caption = "Außerhalb" ' ... direkt in der Form ein "Pseudo-Ereignis" aufrufen ' * Wichtiger Hinweis siehe Anmerkung am Ende des Tipps! Call CallByName(fForm, Ctrl.Name & "_MouseOut", VbMethod) End Sub Beispiele für die Anwendung Beispiel 1: Private Sub Picture1_MouseMove(Button As Integer, _ Shift As Integer, X As Single, Y As Single) Call PrüfeMouseOver(Me, Picture1) End Sub Beispiel 2 (Steuerelemente-Feld): Private Sub Label2_MouseMove(Index As Integer, Button As Integer, _ Shift As Integer, X As Single, Y As Single) Call PrüfeMouseOver(Me, Label2(Index)) End Sub Wichtiger Hinweis für "CallByName" Aufruf-Beispiel für "Pseudo-Ereignise": ' Starten der MouseInOut-Überwachung Private Sub Label2_MouseMove(Button As Integer, _ Shift As Integer, X As Single, Y As Single) Call PrüfeMouseOver(Me, Label2) End Sub ' "Pseudo-Ereignis" für Maus-Eintritt Public Sub Label2_MouseIn() Beep End Sub ' "Pseudo-Ereignis" für Maus-Drüber Public Sub Label2_MouseOver() Label2.ForeColor = vbRed Label1.Caption = "Maus befindet sich über " & Label2.Name End Sub ' "Pseudo-Ereignis" für Maus-Austritt Public Sub Label2_MouseOut() Label2.ForeColor = vbBlack Label1.Caption = "Außerhalb" End Sub |